minischeme: add char

1 files changed, 75 insertions, 7 deletions

diff --git a/miniscm/miniscm.c b/miniscm/miniscm.c
index ea4dc90..96e26eb 100644
--- a/miniscm/miniscm.c
+++ b/miniscm/miniscm.c
@@ -25,6 +25,13 @@
  *--
  */ 
 
+/* 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*.
+ */
+
 /*
  * Here is System declaration.
  * Please define exactly one symbol in the following section.
@@ -66,15 +73,18 @@
  * Define or undefine following symbols as you need.
  */
 /* #define VERBOSE */	/* define this if you want verbose GC */
+#define VERBOSE
 #define	AVOID_HACK_LOOP	/* define this if your compiler is poor
 			 * enougth to complain "do { } while (0)"
 			 * construction.
 			 */
+
+#if 0
 #define USE_SETJMP	/* undef this if you do not want to use setjmp() */
 #define USE_QQUOTE	/* undef this if you do not need quasiquote */
 #define USE_MACRO	/* undef this if you do not need macro */
+#endif
 
-	
 #ifdef USE_QQUOTE
 /*--
  *  If your machine can't support "forward single quotation character"
@@ -102,7 +112,7 @@
 
 
 
-#define banner "Hello, This is Mini-Scheme Interpreter Version 0.85k4-a.\n"
+#define banner "Hello, This is Mini-Scheme Interpreter Version 0.85k4-a for UNSLISP.\n"
 
 
 #include <stdio.h>
@@ -224,6 +234,7 @@ typedef struct cell *pointer;
 # define T_MACRO        256	/* 0000000100000000 */
 #endif
 #define T_PROMISE      512	/* 0000001000000000 */
+#define T_CHAR        1024      /* 0000010000000000 */
 #define T_ATOM       16384	/* 0100000000000000 */	/* only for gc */
 #define CLRATOM      49151	/* 1011111111111111 */	/* only for gc */
 #define MARK         32768	/* 1000000000000000 */
@@ -238,6 +249,7 @@ typedef struct cell *pointer;
 
 #define isnumber(p)     (type(p)&T_NUMBER)
 #define ivalue(p)       ((p)->_object._number._ivalue)
+#define ischar(p)       (type(p)&T_CHAR)
 
 #define ispair(p)       (type(p)&T_PAIR)
 #define car(p)          ((p)->_object._cons._car)
@@ -329,6 +341,18 @@ jmp_buf error_jmp;
 #endif
 char    gc_verbose;		/* if gc_verbose is not zero, print gc status */
 
+stricmp(x, y)
+char *x;
+char *y;
+{
+	for (; tolower((unsigned char)(*x++))
+	       == tolower((unsigned char)(*y++));
+	       x++, y++)
+		if (!*x)
+			break;
+	return *x  - *y;
+}
+
 /* allocate new cell segment */
 alloc_cellseg(n)
 int     n;
@@ -526,6 +550,24 @@ char   *q;
 	return (mk_number(atol(q)));
 }
 
+/* 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) = ' ';
+	} else if (stricmp(name, "newline") == 0) {
+		ivalue(x) = '\n';
+	} else {
+		ivalue(x) = *name;
+	}
+
+	return x;
+}
+
 /* make constant */
 pointer mk_const(name)
 char   *name;
@@ -548,8 +590,11 @@ char   *name;
 		sprintf(tmp, "0x%s", &name[1]);
 		sscanf(tmp, "%lx", &x);
 		return (mk_number(x));
-	} else
+	} else if (*name == '\\') { /* Character constant */
+		return (mk_char(&name[1]));
+	} else {
 		return (NIL);
+	}
 }
 
 
@@ -858,6 +903,16 @@ int     f;
 		p = "#<CLOSURE>";
 	else if (iscontinuation(l))
 		p = "#<CONTINUATION>";
+	else if (ischar(l)) {
+		if (ivalue(l) == '\n')
+			p = "#\\newline";
+		else if (ivalue(l) == ' ')
+			p = "#\\space";
+		else {
+			p = strbuff;
+			sprintf(p, "#\\%c", ivalue(l));
+		}
+	}
 	if (f < 0)
 		return strlen(p);
 	fputs(p, outfp);
@@ -948,6 +1003,11 @@ register pointer a, b;
 			return (ivalue(a) == ivalue(b));
 		else
 			return (0);
+	} else if (ischar(a)) {
+		if (ischar(b))
+			return (ivalue(a) == ivalue(b));
+		else
+			return (0);
 	} else
 		return (a == b);
 }
@@ -1115,7 +1175,7 @@ register pointer a, b;
 #define	OP_GET_CLOSURE		101
 #define	OP_CLOSUREP		102
 #define	OP_MACROP		103
-
+#define OP_CHAR                 104
 
 static FILE *tmpfp;
 static int tok;
@@ -1716,6 +1776,8 @@ register short op;
 		s_retbool(issymbol(car(args)));
 	case OP_NUMBER:	/* number? */
 		s_retbool(isnumber(car(args)));
+	case OP_CHAR: /* char? */
+		s_retbool(ischar(car(args)));
 	case OP_STRING:	/* string? */
 		s_retbool(isstring(car(args)));
 	case OP_PROC:		/* procedure? */
@@ -1958,6 +2020,7 @@ register short op;
 			fprintf(outfp, "'");
 			args = cadr(args);
 			s_goto(OP_P0LIST);
+#ifdef USE_QQUOTE
 		} else if (car(args) == QQUOTE && ok_abbrev(cdr(args))) {
 			fprintf(outfp, "`");
 			args = cadr(args);
@@ -1970,6 +2033,7 @@ register short op;
 			fprintf(outfp, ",@");
 			args = cadr(args);
 			s_goto(OP_P0LIST);
+#endif
 		} else {
 			fprintf(outfp, "(");
 			s_save(OP_P1LIST, cdr(args), NIL);
@@ -2045,6 +2109,7 @@ register short op;
 			++w;
 			args = cadr(args);
 			s_goto(OP_P0_WIDTH);
+#ifdef USE_QQUOTE
 		} else if (car(args) == QQUOTE
 			   && ok_abbrev(cdr(args))) {
 			++w;
@@ -2060,6 +2125,7 @@ register short op;
 			w += 2;
 			args = cadr(args);
 			s_goto(OP_P0_WIDTH);
+#endif
 		} else {
 			++w;
 			s_save(OP_P1_WIDTH, cdr(args), NIL);
@@ -2231,10 +2297,11 @@ pointer	(*dispatch_table[])() = {
 	opexe_6,	/* OP_P1_WIDTH, */
 	opexe_6,	/* OP_GET_CLOSURE, */
 	opexe_6,	/* OP_CLOSUREP, */
-#ifdef USE_MACRO
+	/* OP_MACROP is kept in to fill in a slot. Will return illegal
+	 * operator when macros are disabled. */
 	opexe_6,	/* OP_MACROP, */
-#endif
-	
+
+	opexe_3         /* OP_CHAR */
 };
 
 
@@ -2382,6 +2449,7 @@ init_procs()
 	mk_proc(OP_MACROP, "macro?");	/* a.k */
 #endif
 	mk_proc(OP_QUIT, "quit");
+	mk_proc(OP_CHAR, "char?");
 }