From 93cfe0d94aac238ceb0493752655a4a348485430 Mon Sep 17 00:00:00 2001 From: Peter McGoron Date: Thu, 22 Aug 2024 21:51:25 -0400 Subject: [PATCH] minischeme: add char --- Makefile | 4 +-- README.rst | 2 ++ miniscm/init.scm | 3 -- miniscm/miniscm.c | 82 +++++++++++++++++++++++++++++++++++++++++++---- 4 files changed, 79 insertions(+), 12 deletions(-) diff --git a/Makefile b/Makefile index 357e144..8aa9de1 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,7 @@ miniscm-run-tests: miniscm/scm tests.scm ./miniscm/scm < tests.scm -miniscm/scm: - c89 -DSYSV -DInitFile=\"miniscm/init.scm\" miniscm/miniscm.c -o miniscm/scm +miniscm/scm: miniscm/miniscm.c + c89 -g -DSYSV -DInitFile=\"miniscm/init.scm\" miniscm/miniscm.c -o miniscm/scm clean: rm -f miniscm diff --git a/README.rst b/README.rst index cd78e66..fe60d08 100644 --- a/README.rst +++ b/README.rst @@ -17,6 +17,8 @@ designed to be used by a severely limited Scheme interpreter, which * lacks ``call/cc``, ``call-with-values``, etc * lacks user definable macros * only uses required features from R3RS + (except ``open-input-port``, ``close-input-port``, ``read-char``, + ``open-output-port``, ``close-output-port``, ``write-char``) * has fixnums only * minimizes the use of strings * does not use "load" recursively diff --git a/miniscm/init.scm b/miniscm/init.scm index cbc8e37..2fa3619 100644 --- a/miniscm/init.scm +++ b/miniscm/init.scm @@ -73,6 +73,3 @@ (equal? (cdr x) (cdr y))) (and (not (pair? y)) (eqv? x y)))) - -(display "This is a limited version of MiniScheme used to run UNSLISP.") - 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 @@ -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 = "#"; else if (iscontinuation(l)) p = "#"; + 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?"); }