minischeme: add char
This commit is contained in:
parent
45cfd8ff11
commit
93cfe0d94a
4
Makefile
4
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.")
|
||||
|
||||
|
|
|
|||
|
|
@ -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?");
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue