miniscm: add ports

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?

miniscm/miniscm.c

@@ -25,11 +25,17 @@
  *--
  */ 
 
-/* TODO: Add basic port operations.
+/* This version of MiniScheme has been modified to bootstrap UNSLISP.
- * 
+ *
- * UNSLISP only needs one input port and one output port (besides stdin
+ * Additions:
- * and stdout). The easiest thing to do is to make ports integers that
+ * * Proper support for disabling quasiquote
- * reference a global list of FILE*.
+ * * 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 <stdio.h>
@@ -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';
+		name[0] = '\n';
-	} else {
-		ivalue(x) = *name;
 	}
 
-	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, "#<PORT %ld>", 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");
 }
 
 

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")