diff --git a/miniscm/init.scm b/miniscm/init.scm index 2fa3619..6db7145 100644 --- a/miniscm/init.scm +++ b/miniscm/init.scm @@ -52,6 +52,8 @@ (define (tail stream) (force (cdr stream))) +(define (eof-object? x) (eq? x #f)) + ;;;;; following part is written by a.k ;;;; atom? diff --git a/miniscm/miniscm.c b/miniscm/miniscm.c index 96e26eb..ec10d60 100644 --- a/miniscm/miniscm.c +++ b/miniscm/miniscm.c @@ -25,11 +25,17 @@ *-- */ -/* TODO: Add basic port operations. - * - * UNSLISP only needs one input port and one output port (besides stdin - * and stdout). The easiest thing to do is to make ports integers that - * reference a global list of FILE*. +/* This version of MiniScheme has been modified to bootstrap UNSLISP. + * + * Additions: + * * Proper support for disabling quasiquote + * * Chars + * * Proper support for changing init file by preprocessor define + * * Ports + * + * Ports and chars only support the minimum necessary to run UNSLISP. + * The eof-object is #f. (Defining an entire type for EOF seems like + * a kludge. An EOF test function would be a better design.) */ /* @@ -112,7 +118,8 @@ -#define banner "Hello, This is Mini-Scheme Interpreter Version 0.85k4-a for UNSLISP.\n" +#define banner "UNSLISP MiniScheme 0.85k4-a fork. Must be run from the \n\ +UNSLISP repository root directory.\n" #include @@ -235,6 +242,7 @@ typedef struct cell *pointer; #endif #define T_PROMISE 512 /* 0000001000000000 */ #define T_CHAR 1024 /* 0000010000000000 */ +#define T_PORT 2048 /* 0000100000000000 */ #define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ #define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ #define MARK 32768 /* 1000000000000000 */ @@ -260,6 +268,8 @@ typedef struct cell *pointer; #define hasprop(p) (type(p)&T_SYMBOL) #define symprop(p) cdr(p) +#define isport(p) (type(p)&T_PORT) + #define issyntax(p) (type(p)&T_SYNTAX) #define isproc(p) (type(p)&T_PROC) #define syntaxname(p) strvalue(car(p)) @@ -335,6 +345,11 @@ long fcells = 0; /* # of free cells */ FILE *infp; /* input file */ FILE *outfp; /* output file */ +#ifndef PORTMAX +# define PORTMAX 8 +#endif +FILE *ports[PORTMAX]; /* Ports */ + #ifdef USE_SETJMP jmp_buf error_jmp; @@ -550,22 +565,27 @@ char *q; return (mk_number(atol(q))); } +pointer mk_char_c(c) +char c; +{ + register pointer x = get_cell(NIL, NIL); + type(x) = (T_CHAR | T_ATOM); + ivalue(x) = c; + + return x; +} + /* make char */ pointer mk_char(name) char *name; { - register pointer x = get_cell(NIL, NIL); - type(x) = (T_CHAR | T_ATOM); - if (stricmp(name, "space") == 0) { - ivalue(x) = ' '; + name[0] = ' '; } else if (stricmp(name, "newline") == 0) { - ivalue(x) = '\n'; - } else { - ivalue(x) = *name; + name[0] = '\n'; } - return x; + return mk_char_c(name[0]); } /* make constant */ @@ -912,6 +932,9 @@ int f; p = strbuff; sprintf(p, "#\\%c", ivalue(l)); } + } else if (isport(l)) { + p = strbuff; + sprintf(p, "#", ivalue(l)); } if (f < 0) return strlen(p); @@ -1008,6 +1031,11 @@ register pointer a, b; return (ivalue(a) == ivalue(b)); else return (0); + } else if (isport(a)) { + if (isport(b)) + return (ivalue(a) == ivalue(b)); + else + return (0); } else return (a == b); } @@ -1177,6 +1205,14 @@ register pointer a, b; #define OP_MACROP 103 #define OP_CHAR 104 +#define OP_OPENIN 105 +#define OP_CLOSEIN 106 +#define OP_READIN 107 + +#define OP_OPENOUT 108 +#define OP_CLOSEOUT 109 +#define OP_WRITEOUT 110 + static FILE *tmpfp; static int tok; static int print_flag; @@ -2182,7 +2218,110 @@ register short op; return T; /* NOTREACHED */ } +#define CANNOT_OPEN_FILE -1 +#define TOO_MANY_PORTS -2 +int try_to_open(name, mode) +const char *name; +const char *mode; +{ + register int x; + for (x = 0; x < PORTMAX; x++) { + if (ports[x] == NULL) { + ports[x] = fopen(name, mode); + if (!ports[x]) + return CANNOT_OPEN_FILE; + return x; + } + } + + return TOO_MANY_PORTS; +} + +pointer mk_port(port) +int port; +{ + register pointer x = get_cell(NIL, NIL); + type(x) = (T_PORT | T_ATOM); + ivalue(x) = port; + return x; +} + +pointer opexe_7(op) +register short op; +{ + pointer x; + int port; + + switch (op) { + case OP_OPENIN: case OP_OPENOUT: + if (!isstring(car(args))) { + Error_0("open-input/output-file -- argument is not string"); + } + port = try_to_open(strvalue(car(args)), op == OP_OPENIN ? "rb" : "wb"); + switch (port) { + case CANNOT_OPEN_FILE: + Error_1("open-input/output-file -- cannot open file", car(args)); + case TOO_MANY_PORTS: + Error_0("open-input/output-file -- too many ports open"); + default: + x = mk_port(port); + s_return(x); + } + case OP_CLOSEIN: case OP_CLOSEOUT: + if (!isport(car(args))) { + Error_0("close-input/output-file -- argument is not port"); + } + + port = ivalue(car(args)); + if (port < 0 || port >= PORTMAX) { + Error_0("close-input/output-file -- corrupted port value"); + } + + fclose(ports[port]); + ports[port] = NULL; + s_return(T); + case OP_READIN: + if (!isport(car(args))) { + Error_0("read-char -- argument is not port"); + } + + port = ivalue(car(args)); + if (port < 0 || port >= PORTMAX) { + Error_0("read-char -- corrupted port value"); + } + + port = getc(ports[port]); + if (port == EOF) { + x = F; + } else { + x = mk_char_c((char)port); + } + + s_return(x); + case OP_WRITEOUT: + if (!isport(car(args))) { + Error_0("write-char -- 1st argument is not port"); + } + + if (!ischar(cadr(args))) { + Error_0("write-char -- 2nd argument is not char"); + } + + port = ivalue(car(args)); + if (port < 0 || port >= PORTMAX) { + Error_0("read-char -- corrupted port value"); + } + + putc((char)ivalue(cadr(args)), ports[port]); + s_return(T); + default: + sprintf(strbuff, "%d is illegal operator", operator); + Error_0(strbuff); + } + + return T; +} pointer (*dispatch_table[])() = { @@ -2301,7 +2440,14 @@ pointer (*dispatch_table[])() = { * operator when macros are disabled. */ opexe_6, /* OP_MACROP, */ - opexe_3 /* OP_CHAR */ + opexe_3, /* OP_CHAR */ + + opexe_7, /* OP_OPENIN */ + opexe_7, /* OP_CLOSEIN */ + opexe_7, /* OP_READIN */ + opexe_7, /* OP_OPENOUT */ + opexe_7, /* OP_CLOSEOUT */ + opexe_7 /* OP_WRITEOUT */ }; @@ -2450,6 +2596,14 @@ init_procs() #endif mk_proc(OP_QUIT, "quit"); mk_proc(OP_CHAR, "char?"); + + mk_proc(OP_OPENIN, "open-input-file"); + mk_proc(OP_CLOSEIN, "close-input-port"); + mk_proc(OP_READIN, "read-char"); + + mk_proc(OP_OPENOUT, "open-output-file"); + mk_proc(OP_CLOSEOUT, "close-output-port"); + mk_proc(OP_WRITEOUT, "write-char"); } diff --git a/miniscm/test.scm b/miniscm/test.scm new file mode 100644 index 0000000..dfd219b --- /dev/null +++ b/miniscm/test.scm @@ -0,0 +1,18 @@ +(define copy + (lambda (from to) + (let ((from-file (open-input-file from)) + (to-file (open-output-file to))) + (letrec + ((loop + (lambda () + (let ((c (read-char from-file))) + (if (eof-object? c) + #f + (begin + (write-char to-file c) + (loop))))))) + (loop)) + (close-input-port from-file) + (close-output-port to-file)))) + +(copy "miniscm/miniscm.c" "/tmp/miniscm-copy.c") \ No newline at end of file