#console $filename "OxyScheme.exe" includepath "$\inc\" 'include "Rtl32.inc" include "Console.inc" indexbase 0 // C COMPATIBILITY STUFF ' =================== setjmp/longjmp GCC ====================== /* * The buffer used by setjmp to store the information used by longjmp * to perform it's evil goto-like work. The size of this buffer was * determined through experimentation; it's contents are a mystery. * NOTE: This was determined on an i386 (actually a Pentium). The * contents could be different on an Alpha or something else. */ #define _JBLEN 16 #define _JBTYPE int // typedef _JBTYPE jmp_buf[_JBLEN] /* * The function provided by CRTDLL which appears to do the actual work * of setjmp. */ ! function _setjmp cdecl lib "msvcrt.dll" (sys jmp_buf) as int #define setjmp(x) _setjmp(x) /* * Return to the last setjmp call and act as if setjmp had returned * nVal (which had better be non-zero!). */ ! sub longjmp cdecl lib "msvcrt.dll" (sys jmp_buf, int i) ' ============================================================= type FILE char* _ptr int _cnt char* _base int _flag int _file int _charbuf int _bufsiz char* _tmpfname end type extern cdecl lib "msvcrt.dll" // 32 bits only regardless of "sys"!!! ! __p__iob () as sys ! _open_osfhandle (sys a, b) as sys ! _fdopen (sys a, char* b) as sys ! setvbuf (sys a, char* b, sys c, d) // ---------------------------------------------- ! fopen (sys a, char* b) as sys ! fprintf (sys a, char* b, ...) ! fgets (sys a, b, c) as sys ! fputs (sys a, b) ! feof (sys a) as sys ! fclose (sys a) // ---------------------------------------------- ! sprintf (char* a, char* b, ...) ! sscanf (char* a, char* b, ...) ! printf (char* a, ...) // ---------------------------------------------- ! malloc (sys a) as sys ! memcpy (sys a, b, c) ! realloc (sys a, b) as sys ! free (sys a) // ---------------------------------------------- ! strcmp (sys a, char* b) as sys ! _strcmpi (sys a, sys b) as sys ! strcpy (sys a, char* b) as sys ! strlen (sys a) as sys ! _strlwr (char* a) as char* // ---------------------------------------------- ! isdigit (int a) as sys ! isspace (int a) as sys // ---------------------------------------------- ! atof (char* a) as double ! _atoi64 (char* a) as quad ' returns __i64 in eax:edx=lo:hi ! _i64toa (quad a, sys b, sys c) end extern #define _IONBF &H4 #define _O_TEXT &H4000 #define STDIN_FILENO 0 #define STDOUT_FILENO 1 #define STDERR_FILENO 2 #define stdin @_iob[STDIN_FILENO] #define stdout @_iob[STDOUT_FILENO] #define stderr @_iob[STDERR_FILENO] FILE* _iob = __p__iob() sys hCrt = _open_osfhandle(ConsIn, _O_TEXT) sys hf = _fdopen(hCrt, "r") memcpy stdin, hf, sizeof(FILE) setvbuf stdin, NULL, _IONBF, 0 hCrt = _open_osfhandle(ConsOut, _O_TEXT) hf = _fdopen(hCrt, "w") memcpy stdout, hf, sizeof(FILE) setvbuf stdout, NULL, _IONBF, 0 ConsErr = GetStdHandle STD_ERROR_HANDLE // not gotten in Console.inc!!! hCrt = _open_osfhandle(ConsErr, _O_TEXT) hf = _fdopen(hCrt, "w") memcpy stderr, hf, sizeof(FILE) setvbuf stderr, NULL, _IONBF, 0 // NANOSCHEME PROPER //#define VERBOSE #define USE_SETJMP #define BACKQUOTE 0x60 /* * Basic memory allocation units */ #define CELL_SEGSIZE 5000 /* # of cells in one segment */ #define CELL_NSEGMENT 100 /* # of segments for cells */ #define STR_SEGSIZE 2500 /* bytes of one string segment */ #define STR_NSEGMENT 100 /* # of segments for strings */ #define banner "==========================" & cr & "OxySCHEME Interpreter Beta" & cr & "==========================" & cr & cr #define prompt "> " #define InitFile "nsinit.scm" #define FIRST_CELLSEGS 3 /* cell structure */ type cell sys _A // placeholder sys _B // placeholder sys _flag // type of cell end type #define T_STRING 1 /* 0000000000000001 */ #define T_NUMBER 2 /* 0000000000000010 */ #define T_SYMBOL 4 /* 0000000000000100 */ #define T_SYNTAX 8 /* 0000000000001000 */ #define T_PROC 16 /* 0000000000010000 */ #define T_PAIR 32 /* 0000000000100000 */ #define T_CLOSURE 64 /* 0000000001000000 */ #define T_CONTINUATION 128 /* 0000000010000000 */ #define T_MACRO 256 /* 0000000100000000 */ #define T_PROMISE 512 /* 0000001000000000 */ #define T_ATOM 16384 /* 0100000000000000 *//* only for gc */ #define CLEARATOM 114687 /* 11011111111111111 *//* only for gc */ #define DOMARK 32768 /* 01000000000000000 */ #define UNMARK 98303 /* 10111111111111111 */ #define T_FIXNUM T_NUMBER #define T_FLONUM 65538 /* 10000000000000010 *//* also implies T_NUMBER */ /* macros for cell operations */ #define flag(p) *(p + sizeof(sys) + sizeof(sys)) #define isstring(p) (flag(p) & T_STRING) #define strvalue(p) *p #define keynum(p) *(p + sizeof(sys)) #define ivalue(p) cast quad * p #define rvalue(p) cast double * p #define isnumber(p) (flag(p) & T_NUMBER) #define isfixnum(p) ((flag(p) & T_FLONUM) == T_FIXNUM) #define isflonum(p) ((flag(p) & T_FLONUM) == T_FLONUM) #define isflint(p) (trunc(rvalue(p)) == rvalue(p)) double num_ivalue(sys p) at @num_ivalue_asm 'stores correctly to quad double num_rvalue(sys p) at @num_rvalue_asm 'identical to num_ivalue #define ispair(p) (flag(p) & T_PAIR) #define car(p) *p #define cdr(p) *(p + sizeof(sys)) #define issymbol(p) (flag(p) & T_SYMBOL) #define symname(p) strvalue(car(p)) #define hasprop(p) (flag(p) & T_SYMBOL) #define symprop(p) cdr(p) #define issyntax(p) (flag(p) & T_SYNTAX) #define isproc(p) (flag(p) & T_PROC) #define syntaxname(p) strvalue(car(p)) #define syntaxnum(p) keynum(car(p)) #define procnum(p) ivalue(p) #define isclosure(p) (flag(p) & T_CLOSURE) #define ismacro(p) (flag(p) & T_MACRO) #define closure_code(p) car(p) #define closure_env(p) cdr(p) #define iscontinuation(p) (flag(p) & T_CONTINUATION) #define cont_dump(p) cdr(p) #define ispromise(p) (flag(p) & T_PROMISE) #define setpromise(p) flag(p) |= T_PROMISE #define isatom(p) (flag(p) & T_ATOM) #define setatom(p) flag(p) |= T_ATOM #define clratom(p) flag(p) &= CLEARATOM #define ismark(p) (flag(p) & DOMARK) #define setmark(p) flag(p) |= DOMARK #define clrmark(p) flag(p) &= UNMARK #define backchar() currentline-- #define clearinput() currentline = endline := linebuff #define caar(p) car(car(p)) #define cadr(p) car(cdr(p)) #define cdar(p) cdr(car(p)) #define cddr(p) cdr(cdr(p)) #define cadar(p) car(cdr(car(p))) #define caddr(p) car(cdr(cdr(p))) #define cdddr(p) cdr(cdr(cdr(p))) #define cadaar(p) car(cdr(car(car(p)))) #define cadddr(p) car(cdr(cdr(cdr(p)))) #define cddddr(p) cdr(cdr(cdr(cdr(p)))) /* token types */ enum TOKS { TOK_EOF = -1, TOK_LPAREN = 0, TOK_RPAREN, TOK_DOT, TOK_ATOM, TOK_QUOTE, TOK_COMMENT, TOK_DQUOTE, TOK_BQUOTE, TOK_COMMA, TOK_ATMARK, TOK_SHARP } /* operator codes */ enum OPS { OP_LOAD = 0, OP_T0LVL, OP_T1LVL, OP_GENSYM, OP_READ, OP_VALUEPRINT, OP_EVAL, OP_E0ARGS, OP_E1ARGS, OP_APPLY, OP_DOMACRO, OP_LAMBDA, OP_QUOTE, OP_DEF0, OP_DEF1, OP_BEGIN, OP_IF0, OP_IF1, OP_SET0, OP_SET1, OP_LET0, OP_LET1, OP_LET2, OP_LET0AST, OP_LET1AST, OP_LET2AST, OP_LET0REC, OP_LET1REC, OP_LET2REC, OP_COND0, OP_COND1, OP_DELAY, OP_AND0, OP_AND1, OP_OR0, OP_OR1, OP_C0STREAM, OP_C1STREAM, OP_0MACRO, OP_1MACRO, OP_CASE0, OP_CASE1, OP_CASE2, OP_PEVAL, OP_PAPPLY, OP_CONTINUATION, OP_ADD, OP_SUB, OP_MUL, OP_DIV, OP_ABS, OP_MIN, OP_MAX, OP_QUOTNT, OP_REM, OP_MODULO, OP_GCD, OP_LCM, OP_NUMER, OP_DENOM, OP_INEXEX, OP_EXINEX, OP_SIN, OP_COS, OP_TAN, OP_ASIN, OP_ACOS, OP_ATAN, OP_EXP, OP_LOG, OP_SQRT, OP_EXPT, OP_FLOOR, OP_CEIL, OP_TRUNC, OP_ROUND, OP_CAR, OP_CDR, OP_CONS, OP_SETCAR, OP_SETCDR, OP_NOT, OP_BOOL, OP_NULL, OP_ZEROP, OP_POSP, OP_NEGP, OP_ODDP, OP_EVNP, OP_NEQ, OP_LESS, OP_GRE, OP_LEQ, OP_GEQ, OP_SYMBOL, OP_NUMBER, OP_INTEGER, OP_RATIONAL, OP_REAL, OP_COMPLEX, OP_EXACT, OP_INEXACT, OP_STRING, OP_PROC, OP_PAIR, OP_EQ, OP_EQV, OP_FORCE, OP_WRITE, OP_DISPLAY, OP_NEWLINE, OP_ERR0, OP_ERR1, OP_REVERSE, OP_APPEND, OP_PUT, OP_GET, OP_QUIT, OP_GC, OP_GCVERB, OP_NEWSEGMENT, OP_RDSEXPR, OP_RDLIST, OP_RDDOT, OP_RDQUOTE, OP_RDQQUOTE, OP_RDUNQUOTE, OP_RDUQTSP, OP_P0LIST, OP_P1LIST, OP_IS_LIST, OP_LIST_LENGTH, OP_ASSQ, OP_PRINT_WIDTH, OP_P0_WIDTH, OP_P1_WIDTH, OP_GET_CLOSURE, OP_CLOSUREP, OP_MACROP, OP_NUMSTR, OP_STRNUM, OP_SYMSTR, OP_STRSYM, OP_MKSTR, OP_STRLEN, OP_STREQ, OP_STRLS, OP_STRGT, OP_STRLEQ, OP_STRGEQ, OP_STREQI, OP_STRLSI, OP_STRGTI, OP_STRLEQI, OP_STRGEQI, OP_SUBSTR, OP_STRAPP } /* arrays for segments */ sys cell_seg[CELL_NSEGMENT] sys last_cell_seg = -1 sys str_seg[STR_NSEGMENT] sys str_seglast = -1 // automatic symbol generator sys sym_count /* We use 4 registers. */ sys args /* register for arguments of function */ sys envir /* stack register for current environment */ sys code /* register for current code */ sys dump /* stack register for next evaluation */ cell _NIL sys NIL = @_NIL /* special cell representing empty cell */ cell _T sys T = @_T /* special cell representing #t */ cell _F sys F = @_F /* special cell representing #f */ cell _EOF_OBJ sys EOF_OBJ = @_EOF_OBJ /* special cell representing EOF */ sys oblist = @_NIL /* pointer to symbol table */ sys global_env /* pointer to global environment */ /* global pointers to special symbols */ sys LAMBDA /* pointer to syntax lambda */ sys SQUOTE /* pointer to syntax quote */ sys QQUOTE /* pointer to symbol quasiquote */ sys UNQUOTE /* pointer to symbol unquote */ sys UNQUOTESP /* pointer to symbol unquote-splicing */ sys free_cell = @_NIL /* pointer to top of free cells */ sys fcells = 0 /* # of free cells */ sys infp /* input file */ sys outfp /* output file */ #ifdef USE_SETJMP _JBTYPE error_jmp[_JBLEN] #endif sys gc_verbose /* if gc_verbose is not zero, print gc status */ /* FILE* */ sys tmpfp sys tok sys print_flag sys value sys operator // helper funcs ! ExitProcess lib "kernel32.dll" (DWORD uExitCode) // forward declarations ! sub init_globals () ! sub gc (sys a, b) ! sub flushinput () '! function atoll (char* a) as quad at @atoll_asm ! function gcd (quad a, b) as quad ! function scm (quad a, b) as quad /* ========== Errors ============ */ sub FatalError(char *fmt, *a, *b, *c) fprintf(stderr, "Fatal error: ") fprintf(stderr, fmt, a, b, c) fprintf(stderr, cr) ExitProcess(-1) end sub #ifdef USE_SETJMP sub Error(char *fmt, *a, *b, *c) fprintf(stderr, "Error: ") fprintf(stderr, fmt, a, b, c) fprintf(stderr, cr) flushinput() longjmp(@error_jmp, OP_T0LVL) end sub #endif /* allocate new cell segment */ function alloc_cellseg(sys n) as sys sys p sys i, k for k = 0 to k < n if (last_cell_seg >= CELL_NSEGMENT - 1) then return k p = malloc(CELL_SEGSIZE * sizeof(cell)) if (p == NULL) then return k last_cell_seg++ cell_seg[last_cell_seg] = p fcells += CELL_SEGSIZE for i = 0 to i < CELL_SEGSIZE - 1 flag(p) = 0 car(p) = NIL cdr(p) = p + sizeof(cell) // no pointer arith in O2 p += sizeof(cell) next flag(p) = 0 car(p) = NIL cdr(p) = free_cell free_cell = cell_seg[last_cell_seg] next return n end function /* allocate new string segment */ function alloc_strseg(sys n) as sys =================================== // char* p sys p sys i, k for k = 0 to k < n if (str_seglast >= STR_NSEGMENT) then return k p = malloc(STR_SEGSIZE * sizeof(char)) if (p == NULL) then return k str_seglast++ str_seg[str_seglast] = p scope byte b at p for i = 0 to < STR_SEGSIZE b = 0xFF @b++ next end scope next return n end function /* get new cell. parameter a, b is marked by gc. */ function get_cell(sys a, b) as sys ================================== sys x if (free_cell == NIL) then gc(a, b) if (free_cell == NIL) then #ifdef USE_SETJMP if (alloc_cellseg(1) == 0) then args = envir := code := dump := NIL gc(NIL, NIL) if (free_cell != NIL) then Error("run out of cells, returning to top level", "" , "", "") else FatalError("run out of cells, unable to recover", "", "", "") end if end if #else if (alloc_cellseg(1) == 0) then FatalError("run out of cells, unable to recover", "", "", "") end if #endif end if end if x = free_cell free_cell = cdr(x) fcells-- return x end function /* get new cons cell */ function cons(sys a, b) as sys sys x = get_cell(a, b) flag(x) = T_PAIR car(x) = a cdr(x) = b return x end function /* get number atom */ function mk_number(quad num) as sys sys x = get_cell(NIL, NIL) flag(x) = (T_NUMBER | T_ATOM) ivalue(x) = num return x end function /* get number atom (integer) */ function mk_integer(quad num) as sys sys x = get_cell(NIL, NIL) flag(x) = (T_FIXNUM | T_ATOM) ivalue(x) = num return x end function /* get number atom (real) */ function mk_real(double d) as sys sys x = get_cell(NIL, NIL) flag(x) = (T_FLONUM | T_ATOM) rvalue(x) = d return x end function /* allocate name to string area */ function store_string(char* name) as sys'string sys p sys i sys length, remain /* first check name has already listed */ for i = 0 to <= str_seglast p = str_seg[i] scope byte b at p while (b != 0xFF) if (strcmp(@b, name) == 0) then p = @b goto FOUND end if while (b) // advance byte-by-byte until trailing zero @b++ wend @b++ /* get next string */ wend p = @b end scope next length = len(name) + 2 remain = STR_SEGSIZE - (p - str_seg[str_seglast]) if (remain < length) then if (alloc_strseg(1) == 0) then FatalError("run out of string area", "", "", "") end if p = str_seg[str_seglast] end if strcpy(p, name) FOUND: return p end function /* get new string */ function mk_string(char* s) as sys, label // for 'string-append' sys x = get_cell(NIL, NIL) strvalue(x) = store_string(s) flag(x) = (T_STRING | T_ATOM) keynum(x) = -1 return x end function /* get new symbol */ function mk_symbol(char* name) as sys sys x /* fisrt check oblist */ x = oblist while (x != NIL) if (strcmp(symname(car(x)), name) == 0) then exit while x = cdr(x) wend if (x != NIL) then return car(x) end if x = cons(mk_string(name), NIL) flag(x) = T_SYMBOL oblist = cons(x, oblist) return x end function // automatic symbol generator function auto_gen() as sys char newsym[40] = "autosym-" & sym_count sym_count++ return mk_symbol(newsym) end function /* make symbol or number atom from string */ function mk_atom(char* s) as sys byte c at strptr s int has_dec_point = 0 int has_fp_exp = 0 if ((c == 0x2B) || (c == 0x2D)) then // '+' '-' @c++ if (c == 0x2E) then // '.' has_dec_point = 1 @c++ end if if (isdigit(c) == 0) then return mk_symbol(_strlwr(s)) else if (c == 0x2E) then // '.' has_dec_point = 1 @c++ if (isdigit(c) == 0) then return mk_symbol(_strlwr(s)) else if (isdigit(c) == 0) then return mk_symbol(_strlwr(s)) end if while (c != 0) if (isdigit(c) == 0) then if (c == 0x2E) then // '.' if (has_dec_point == 0) then has_dec_point = 1 goto ITERATE end if else if ((c == 0x65) || (c == 0x45)) then // 'e' 'E' if (has_fp_exp == 0) then has_dec_point = 1 /* decimal point illegal from now on */ @c++ if ((c == 0x2D) || (c == 0x2B) || isdigit(c)) then goto ITERATE // '-' '+' end if end if return mk_symbol(_strlwr(s)) end if ITERATE: @c++ wend if (has_dec_point) then return mk_real(atof(s)) return mk_integer(_atoi64(s)) end function function binary_decode(sys s) as quad quad x = 0 byte p at s while ((p != 0) && (p == 0x31 || p == 0x30)) // '1' '0' x *= 2 x += p - 0x30 // '0' @p++ wend return x end function /* make constant */ function mk_const(char* name) as sys // doesn't accept scientific notation for decimals char tmp[128] char n[128] = name byte b at strptr name quad x int advance, inexact // exactness before radix if (b == 0x65) then // 'e' => exact if (instr(name, "#")) then // radix possible @b += 2: advance = 2 else // no radix b = 0x64 // 'd' end if else if (b == 0x69) then // 'i' => inexact if (instr(name, "#")) then // radix possible @b += 2: advance = 2 else // no radix b = 0x64 // 'd' end if inexact = 1 end if if (b == 0x65 || b = 0x69) then return NIL // duplicate '#e'/'#i' // ditto, after 'if ((byte)*(@b + 1) == 0x23) then // '#' if b[2]==0x23 then x = @b : @b++ 'if ((byte)*(@b + 1) == 0x69) then inexact = 1 // 'i' if b[2]==0x69 then inexact = 1 // 'i' do 'b = (byte)*(@b + 2) // overwrite exactness w/ number proper b=b[3] if (b == 0) then exit do @b++ end do @b = x : n = name end if if (strcmp(strptr name, "t") == 0) then if (advance) then return NIL return T else if (strcmp(strptr name, "f") == 0) then if (advance) then return NIL return F else if (b == 0x62) then // 'b' /* #b (binary) */ if (instr(name, ".")) then return NIL // not allowed for radix <> 10 x = binary_decode(@n[1+advance]) if (inexact) then return mk_real(x) return mk_number(x) else if (b == 0x6F) then // 'o' /* #o (octal) */ if (instr(name, ".")) then return NIL // not allowed for radix <> 10 sprintf(tmp, "0%s", @n[1+advance]) sscanf(tmp, "%I64o", @x) if (inexact) then return mk_real(x) return mk_number(x) else if (b == 0x64) then // 'd' /* #d (decimal) */ sprintf(tmp, "%s", @n[1+advance]) sscanf(tmp, "%I64d", @x) if (inexact) then return mk_real(x) return mk_number(x) else if (b == 0x78) then // 'x' /* #x (hex) */ if (instr(name, ".")) then return NIL // not allowed for radix <> 10 sprintf(tmp, "0x%s", @n[1+advance]) sscanf(tmp, "%I64x", @x) if (inexact) then return mk_real(x) return mk_number(x) else return NIL end if end function /* ========== garbage collector ========== */ /*-- * We use algorithm E (Kunuth, The Art of Computer Programming Vol.1, * sec.3.5) for marking. */ sub mark(sys a) =============== sys t, q, p t = 0 p = a E2: setmark(p) if (isatom(p)) then goto E6 q = car(p) if ((q != 0) && (ismark(q) == 0)) then setatom(p) car(p) = t t = p p = q goto E2 end if E5: q = cdr(p) if ((q != 0) && (ismark(q) == 0)) then cdr(p) = t t = p p = q goto E2 end if E6: if (t == 0) then exit sub q = t if (isatom(q)) then clratom(q) t = car(q) car(q) = p p = q goto E5 else t = cdr(q) cdr(q) = p p = q goto E6 end if end sub /* garbage collection. parameter a, b is marked. */ sub gc(sys a, b) ================ sys p sys i, j if (gc_verbose) then printf("gc start ... ") /* mark system globals */ mark(oblist) mark(global_env) /* mark current registers */ mark(args) mark(envir) mark(code) mark(dump) /* mark variables a, b */ mark(a) mark(b) /* garbage collect */ clrmark(NIL) fcells = 0 free_cell = NIL for i = 0 to <= last_cell_seg p = cell_seg[i] for j = 0 to < CELL_SEGSIZE if (ismark(p)) then clrmark(p) else flag(p) = 0 cdr(p) = free_cell car(p) = NIL free_cell = p fcells++ end if p += sizeof(cell) next next if (gc_verbose) then printf("done: %d cells recovered.%s", fcells, cr) end sub /* ========== Routines for Reading ========== */ #define EOF 0xFF // -1 #define LINESIZE 1024 char linebuff[LINESIZE] char strbuff[256] sys currentline = strptr linebuff sys endline = strptr linebuff // this is essentially instr() function is_one_of(char* s, int c) as sys ========================================= byte p at strptr s if (c == EOF) then return 1 while (p) if (p == c) then return 1 @p++ wend return 0 end function /* get new character from input file */ function inchar() as byte ========================= if (currentline >= endline) then /* input buffer is empty */ if (feof(infp)) then fclose(infp) infp = stdin return EOF end if strcpy(strptr linebuff, cr) currentline = strptr linebuff if (fgets(currentline, LINESIZE, infp) == NULL) then if (infp == stdin) then // ^C fprintf(stderr, "Good-bye!%s", cr) ExitProcess(0) end if end if endline = strptr linebuff + len(linebuff) end if function = (cast byte *currentline) currentline++ end function /* back to standard input */ sub flushinput() ================ if (infp != stdin) then fclose(infp) infp = stdin end if clearinput() end sub /* check c is delimiter */ function isdelim(char* s, byte c) as sys // returns 0 if delimiter, 1 if not ======================================== byte b at strptr s while (b) if (b == c) then return 0 @b++ wend return 1 end function /* read chacters to delimiter */ function readstr(char* delim) as char* ====================================== byte b at strptr strbuff b = inchar() while (isdelim(delim, b)) @b++ b = inchar() wend backchar() b = 0 return strbuff end function /* read string expression "xxx...xxx" */ function readstrexp() as char* ============================== byte c byte p at strptr strbuff do c = inchar() if (c != 0x22) then // '"' p = c @p++ 'else if ((@p > strptr(strbuff) ) && (*(@p - 1) == 0x5C)) then // '\' ' *(@p - 1) = 0x22 // '"' elseif @p > strptr(strbuff) && (p[0]==0x5c) ' p[0] is char before. p[0]=0x5C else p = 0 return strbuff end if end do end function /* skip white characters */ function skipspace() as sys =========================== int c = inchar() while (isspace(c)) c = inchar() wend if (c != EOF) then backchar() return 1 end if return EOF end function /* get token */ function token() as sys ======================= sys c = skipspace() if (c == EOF) then return TOK_EOF c = inchar() select case c case EOF return TOK_EOF case 0x28 // '(' return TOK_LPAREN case 0x29 // ')' return TOK_RPAREN case 0x2E // '.' c = inchar() if (is_one_of(" " & chr(0xA), c)) then // space/tab/cr return TOK_DOT else backchar() backchar() return TOK_ATOM // flonum end if case 0x27 // "'" return TOK_QUOTE case 0x3B // ';' ==> bypass comments recursively altogether c = inchar() while ((c != 0xA) && (c != EOF)) // '\n' // skip comments c = inchar() wend if (c == EOF) then return TOK_EOF return token() case 0x22 // '"' return TOK_DQUOTE case BACKQUOTE return TOK_BQUOTE case 0x2C // ',' if (inchar() == 0x40) then return TOK_ATMARK // '@' backchar() return TOK_COMMA case 0x23 // '#' return TOK_SHARP case else backchar() return TOK_ATOM end select end function /* ========== Routines for Printing ========== */ #define ok_abbrev(x) (ispair(x) && (cdr(x) == NIL) && (cdr(x) == NIL)) sub strunquote(sys q, sys r) ============================ byte p at q byte s at r p = 0x22 // '"' @p++ while (s != 0) if (s == 0x22) then // '"' p = 0x5C // '\\' @p++ p = 0x22 // '"' @p++ else if (s == 0xA) then // '\n' p = 0x5C // '\\' @p++ p = 0x6E // 'n' @p++ else p = s @p++ end if @s++ wend p = 0x22 // '"' @p++ p = 0 ' '\0' end sub /* print atoms */ function printatom(sys l, int flg) as int ========================================= char* p = NULL quad q if (l == NIL) then p = "()" else if (l == T) then p = "#t" else if (l == F) then p = "#f" else if (l == EOF_OBJ) then p = "#" else if (isflonum(l)) then // must precede isnumber! (if isnumber (faster) is used instead of isfixnum) p = strbuff if (isflint(l)) then sprintf(p, "%I64d.0", convert quad rvalue(l)) else sprintf(p, "%.15g", rvalue(l)) end if else if (isnumber(l)) then // long long integer p = strbuff sprintf(p, "%I64d", ivalue(l)) else if (isstring(l)) then if (flg == 0) then p = cast char strvalue(l) else p = strbuff strunquote(@p, strvalue(l)) end if else if (issymbol(l)) then p = cast char* symname(l) else if (isproc(l)) then p = strbuff sprintf(p, "#", procnum(l)) else if (ismacro(l)) then p = "#" else if (isclosure(l)) then p = "#" else if (iscontinuation(l)) then p = "#" else p = "#" end if if (flg < 0) then return len(p) fputs(@p, outfp) return 0 end function /* ========== Routines for Evaluation Cycle ========== */ /* make closure. c is code. e is environment */ function mk_closure(sys c, e) as sys ==================================== sys x = get_cell(c, e) flag(x) = T_CLOSURE car(x) = c cdr(x) = e return x end function /* make continuation. */ function mk_continuation(sys d) as sys ====================================== sys x = get_cell(NIL, d) flag(x) = T_CONTINUATION cont_dump(x) = d return x end function /* reverse list -- make new cells */ function reverse(sys a) as sys /* a must be checked by gc */ ============================================================= sys p = NIL while (ispair(a)) p = cons(car(a), p) a = cdr(a) wend return p end function /* reverse list --- no make new cells */ function non_alloc_rev(sys term, list) as sys ============================================= sys p = list, result = term, q while (p != NIL) q = cdr(p) cdr(p) = result result = p p = q wend return result end function /* append list -- make new cells */ function append(sys a, b) as sys ================================ sys p = b, q if (a != NIL) then a = reverse(a) while (a != NIL) q = cdr(a) cdr(a) = p p = a a = q wend end if return p end function /* equivalence of atoms */ function eqv(sys a, b) as sys ============================= if (isstring(a)) then if (isstring(b)) then return (*a == *b) // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! else return 0 end if else if (isflonum(a)) then if (isflonum(b)) then return (rvalue(a) == rvalue(b)) else return 0 end if else if (isnumber(a)) then // faster to check if (isfixnum(b)) then return (ivalue(a) == ivalue(b)) else return 0 end if end if return (a == b) end function /* Result is: proper list: length circular list: -1 not even a pair: -2 dotted list: -2 minus length before dot */ function list_length(sys a) as long =================================== long i = 0 sys slow, fast slow = fast := a do if (fast == NIL) then return i if (ispair(fast) == 0) then return -2 - i fast = cdr(fast) i++ if (fast == NIL) then return i if (ispair(fast) == 0) then return -2 - i i++ fast = cdr(fast) /* Safe because we would have already returned if `fast' encountered a non-pair. */ slow = cdr(slow) if (fast == slow) then /* the fast pointer has looped back around and caught up with the slow pointer, hence the structure is circular, not of finite length, and therefore not a list */ return -1 end if end do end function /* true or false value macro */ #define istrue(p) ((p) != NIL && (p) != F) #define isfalse(p) ((p) == NIL || (p) == F) /* Error macro */ #define Error_0(s) \ args = cons(mk_string((s)), NIL) \ operator = OP_ERR0 \ return T #define Error_1(s, a) \ args = cons((a), NIL) \ args = cons(mk_string((s)), args) \ operator = OP_ERR0 \ return T /* control macros for Eval_Cycle */ #define s_goto(a) \ operator = (a) \ return T #define s_save(a, b, c)( \ dump = cons(envir, cons((c), dump)) \ dump = cons((b), dump) \ dump = cons(mk_number((a)), dump)) #define s_return(a) \ value = (a) \ operator = ivalue(car(dump)) \ args = cadr(dump) \ envir = caddr(dump) \ code = cadddr(dump) \ dump = cddddr(dump) \ return NIL'T // s_return((tf) ? T : F) #define s_retbool(tf) \ if (tf) then \ s_return(T) \ end if \ s_return(F) /* ========== Evaluation Cycle ========== */ function opexe_0(sys op) as sys, label ====================================== sys x, y select case op case OP_LOAD /* load */ if (isstring(car(args)) == 0) then Error_0("argument must be a string") end if infp = fopen(strvalue(car(args)), "r") if (infp == NULL) then infp = stdin Error_1("unable to open", car(args)) end if fprintf(outfp, "loading %s", strvalue(car(args))) s_goto(OP_T0LVL) case OP_T0LVL /* top level */ fprintf(outfp, cr) // "\n") dump = NIL envir = global_env s_save(OP_VALUEPRINT, NIL, NIL) s_save(OP_T1LVL, NIL, NIL) if (infp == stdin) then printf(prompt) end if s_goto(OP_READ) case OP_T1LVL /* top level */ code = value s_goto(OP_EVAL) case OP_GENSYM s_return(auto_gen()) case OP_READ /* read */ tok = token() s_goto(OP_RDSEXPR) case OP_VALUEPRINT /* print evalution result */ print_flag = 1 args = value s_save(OP_T0LVL, NIL, NIL) s_goto(OP_P0LIST) case OP_EVAL /* main part of evalution */ if (issymbol(code)) then /* symbol */ x = envir while (x != NIL) y = car(x) while (y != NIL) if (caar(y) == code) then exit while y = cdr(y) wend if (y != NIL) then exit while x = cdr(x) wend if (x != NIL) then s_return(cdar(y)) else Error_1("unbound variable", code) end if else if (ispair(code)) then x = car(code) if (issyntax(x)) then /* SYNTAX */ code = cdr(code) s_goto(syntaxnum(x)) else /* first, eval top element and eval arguments */ s_save(OP_E0ARGS, NIL, code) code = car(code) s_goto(OP_EVAL) end if end if s_return(code) case OP_E0ARGS /* eval arguments */ if (ismacro(value)) then /* macro expansion */ s_save(OP_DOMACRO, NIL, NIL) args = cons(code, NIL) code = value s_goto(OP_APPLY) end if code = cdr(code) s_goto(OP_E1ARGS) case OP_E1ARGS /* eval arguments */ args = cons(value, args) if (ispair(code)) then /* continue */ s_save(OP_E1ARGS, args, cdr(code)) code = car(code) args = NIL s_goto(OP_EVAL) end if /* else end */ args = reverse(args) code = car(args) args = cdr(args) s_goto(OP_APPLY) case OP_APPLY /* apply 'code' to 'args' */ if (isproc(code)) then /* PROCEDURE */ 's_goto(asc(cast char* code)) // procnum(code) doesn't work here!!! s_goto(cast byte *code) else if (isclosure(code)) then /* CLOSURE */ /* make environment */ envir = cons(NIL, closure_env(code)) x = car(closure_code(code)) y = args while (ispair(x)) if (y == NIL) then Error_0("too few arguments") else car(envir) = cons(cons(car(x), car(y)), car(envir)) end if x = cdr(x) y = cdr(y) wend if (x == NIL) then /*-- * if (y != NIL) { * Error_0("too many arguments"); * } */ else if (issymbol(x)) then car(envir) = cons(cons(x, y), car(envir)) else Error_0("invalid syntax in closure") end if code = cdr(closure_code(code)) args = NIL s_goto(OP_BEGIN) else if (iscontinuation(code)) then /* CONTINUATION */ dump = cont_dump(code) if (args != NIL) then s_return(car(args)) else s_return(NIL) end if end if Error_0("illegal function") case OP_DOMACRO /* do macro */ code = value s_goto(OP_EVAL) case OP_LAMBDA /* lambda */ s_return(mk_closure(code, envir)) case OP_QUOTE /* quote */ s_return(car(code)) case OP_DEF0 /* define */ if ispair(car(code)) then x = caar(code) code = cons(LAMBDA, cons(cdar(code), cdr(code))) else x = car(code) code = cadr(code) end if if (issymbol(x) == 0) then Error_0("variable must be a symbol") end if s_save(OP_DEF1, NIL, x) s_goto(OP_EVAL) case OP_DEF1 /* define */ x = car(envir) while (x != NIL) if (caar(x) == code) then exit while x = cdr(x) wend if (x != NIL) then cdar(x) = value else car(envir) = cons(cons(code, value), car(envir)) end if s_return(code) case OP_SET0 /* set! */ s_save(OP_SET1, NIL, car(code)) code = cadr(code) s_goto(OP_EVAL) case OP_SET1 /* set! */ x = envir while (x != NIL) y = car(x) while (y != NIL) if (caar(y) == code) then exit while y = cdr(y) wend if (y != NIL) then exit while x = cdr(x) wend if (x != NIL) then cdar(y) = value s_return(value) end if Error_1("unbound variable", code) case OP_BEGIN /* begin */ if (ispair(code) == 0) then s_return(code) end if if (cdr(code) != NIL) then s_save(OP_BEGIN, NIL, cdr(code)) end if code = car(code) s_goto(OP_EVAL) case OP_IF0 /* if */ s_save(OP_IF1, NIL, cdr(code)) code = car(code) s_goto(OP_EVAL) case OP_IF1 /* if */ if (istrue(value)) then code = car(code) else code = cadr(code) /* (if #f 1) ==> () because * car(NIL) = NIL */ end if s_goto(OP_EVAL) case OP_LET0 /* let */ args = NIL value = code if issymbol(car(code)) then code = cadr(code) else code = car(code) end if s_goto(OP_LET1) case OP_LET1 /* let (caluculate parameters) */ args = cons(value, args) if (ispair(code)) then /* continue */ s_save(OP_LET1, args, cdr(code)) code = cadar(code) args = NIL s_goto(OP_EVAL) end if /* else end */ args = reverse(args) code = car(args) args = cdr(args) s_goto(OP_LET2) case OP_LET2 /* let */ envir = cons(NIL, envir) if (issymbol(car(code))) then x = cadr(code) else x = car(code) end if y = args while (y != NIL) car(envir) = cons(cons(caar(x), car(y)), car(envir)) x = cdr(x) y = cdr(y) wend if (issymbol(car(code))) then /* named let */ x = cadr(code) args = NIL while (x != NIL) args = cons(caar(x), args) x = cdr(x) wend x = mk_closure(cons(reverse(args), cddr(code)), envir) car(envir) = cons(cons(car(code), x), car(envir)) code = cddr(code) args = NIL else code = cdr(code) args = NIL end if s_goto(OP_BEGIN) case OP_LET0AST /* let* */ if (car(code) == NIL) then envir = cons(NIL, envir) code = cdr(code) s_goto(OP_BEGIN) end if s_save(OP_LET1AST, cdr(code), car(code)) code = cadaar(code) s_goto(OP_EVAL) case OP_LET1AST /* let* (make new frame) */ envir = cons(NIL, envir) s_goto(OP_LET2AST) case OP_LET2AST /* let* (caluculate parameters) */ car(envir) = cons(cons(caar(code), value), car(envir)) code = cdr(code) if (ispair(code)) then /* continue */ s_save(OP_LET2AST, args, code) code = cadar(code) args = NIL s_goto(OP_EVAL) end if /* else end */ code = args args = NIL s_goto(OP_BEGIN) case else sprintf(strbuff, "%d is an illegal operator", operator) Error_0(strbuff) end select return T end function function opexe_1(sys op) as sys, label ====================================== sys x, y select case op case OP_LET0REC /* letrec */ envir = cons(NIL, envir) args = NIL value = code code = car(code) s_goto(OP_LET1REC) case OP_LET1REC /* letrec (caluculate parameters) */ args = cons(value, args) if (ispair(code)) then /* continue */ s_save(OP_LET1REC, args, cdr(code)) code = cadar(code) args = NIL s_goto(OP_EVAL) end if /* else end */ args = reverse(args) code = car(args) args = cdr(args) s_goto(OP_LET2REC) case OP_LET2REC /* letrec */ x = car(code) y = args while (y != NIL) car(envir) = cons(cons(caar(x), car(y)), car(envir)) x = cdr(x) y = cdr(y) wend code = cdr(code) args = NIL s_goto(OP_BEGIN) case OP_COND0 /* cond */ if (ispair(code) == 0) then Error_0("invalid syntax in cond") end if s_save(OP_COND1, NIL, code) code = caar(code) s_goto(OP_EVAL) case OP_COND1 /* cond */ if (istrue(value)) then code = cdar(code) if (code == NIL) then s_return(value) end if s_goto(OP_BEGIN) end if code = cdr(code) if (code == NIL) then s_return(NIL) else s_save(OP_COND1, NIL, code) code = caar(code) s_goto(OP_EVAL) end if case OP_DELAY /* delay */ x = mk_closure(cons(NIL, code), envir) setpromise(x) s_return(x) case OP_AND0 /* and */ if (code == NIL) then s_return(T) end if s_save(OP_AND1, NIL, cdr(code)) code = car(code) s_goto(OP_EVAL) case OP_AND1 /* and */ if (isfalse(value)) then s_return(value) else if (code == NIL) then s_return(value) else s_save(OP_AND1, NIL, cdr(code)) code = car(code) s_goto(OP_EVAL) end if case OP_OR0 /* or */ if (code == NIL) then s_return(F) end if s_save(OP_OR1, NIL, cdr(code)) code = car(code) s_goto(OP_EVAL) case OP_OR1 /* or */ if (istrue(value)) then s_return(value) else if (code == NIL) then s_return(value) else s_save(OP_OR1, NIL, cdr(code)) code = car(code) s_goto(OP_EVAL) end if case OP_C0STREAM /* cons-stream */ s_save(OP_C1STREAM, NIL, cdr(code)) code = car(code) s_goto(OP_EVAL) case OP_C1STREAM /* cons-stream */ args = value /* save value to register args for gc */ x = mk_closure(cons(NIL, code), envir) setpromise(x) s_return(cons(args, x)) case OP_0MACRO /* macro */ x = car(code) code = cadr(code) if (issymbol(x) == 0) then Error_0("variable must be a symbol") end if s_save(OP_1MACRO, NIL, x) s_goto(OP_EVAL) case OP_1MACRO /* macro */ flag(value) |= T_MACRO x = car(envir) while (x != NIL) if (caar(x) == code) then exit while x = cdr(x) wend if (x != NIL) then cdar(x) = value else car(envir) = cons(cons(code, value), car(envir)) end if s_return(code) case OP_CASE0 /* case */ s_save(OP_CASE1, NIL, cdr(code)) code = car(code) s_goto(OP_EVAL) case OP_CASE1 /* case */ x = code while (x != NIL) y = caar(x) if (ispair(y) == 0) then exit while while (y != NIL) if (eqv(car(y), value)) then exit while y = cdr(y) wend if (y != NIL) then exit while x = cdr(x) wend if (x != NIL) then if (ispair(caar(x))) then code = cdar(x) s_goto(OP_BEGIN) else /* else */ s_save(OP_CASE2, NIL, cdar(x)) code = caar(x) s_goto(OP_EVAL) end if end if s_return(NIL) case OP_CASE2 /* case */ if (istrue(value)) then s_goto(OP_BEGIN) end if s_return(NIL) case OP_PAPPLY /* apply */ code = car(args) args = cadr(args) s_goto(OP_APPLY) case OP_PEVAL /* eval */ code = car(args) args = NIL s_goto(OP_EVAL) case OP_CONTINUATION /* call-with-current-continuation */ code = car(args) args = cons(mk_continuation(dump), NIL) s_goto(OP_APPLY) case else sprintf(strbuff, "%d is an illegal operator", operator) Error_0(strbuff) end select return T end function function opexe_2(sys op) as sys, label sys x int is_double quad v double d char s[128] select case op case OP_ADD /* + */ x = args while (x != NIL) if (is_double) then d += num_rvalue(car(x)) else if (isflonum(car(x))) then d = v // 'cast double v' and '(double) v' don't work!!! d += rvalue(car(x)) is_double = 1 else v += ivalue(car(x)) end if end if x = cdr(x) wend goto COMMON1 case OP_SUB /* - */ x = car(args) if (x == NIL) then Error_0("'-' requires at least one argument") end if if (ispair(cdr(args)) == 0) then // just invert sign if (isfixnum(x)) then v -= ivalue(x) s_return(mk_integer(v)) end if d -= rvalue(x) s_return(mk_real(d)) end if if (isflonum(x)) then is_double = 1 d = rvalue(x) else is_double = 0 v = ivalue(x) end if x = cdr(args) while (x != NIL) if (is_double) then d -= num_rvalue(car(x)) else if (isflonum(car(x))) then d = v // 'cast double v' and '(double) v' don't work!!! d -= rvalue(car(x)) is_double = 1 else v -= ivalue(car(x)) end if end if x = cdr(x) wend goto COMMON1 case OP_MUL /* * */ x = args: v = 1: d = 1.0 while (x != NIL) if (is_double) then d *= num_rvalue(car(x)) else if (isflonum(car(x))) then d = v // 'cast double v' and '(double) v' don't work!!! d *= rvalue(car(x)) is_double = 1 else v *= ivalue(car(x)) end if end if x = cdr(x) wend goto COMMON1 case OP_DIV /* / */ x = car(args) if (x == NIL) then Error_0("'/' requires at least one argument") end if if (isflonum(x)) then is_double = 1 d = num_rvalue(x) x = cdr(args) if (d == 0.0 && x == NIL) then Error_0("divizion by zero") end if if (ispair(x) == 0) then s_return(mk_real(1.0 / d)) end if while (x != NIL) if (ivalue(car(x)) != 0) then // 0LL and 0.0 are the same if (isflonum(car(x))) then is_double = 1 d /= num_rvalue(car(x)) else Error_0("divizion by zero") end if x = cdr(x) wend if ((trunc(d) != d) || is_double) then s_return(mk_real(d)) end if s_return(mk_integer(d)) case OP_ABS x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'abs' requires one argument") end if if (isflonum(x)) then is_double = 1 d = abs(num_rvalue(x)) goto COMMON2 case OP_MIN x = args // v = 0x7fffffffffffffff ''9223372036854775807 // d = 1 / 0 // LONG_LONG_MAX, +#INF if ((x == NIL)) then Error_0("'min' requires at least one argument") end if v=num_ivalue(car(x)) d=num_rvalue(car(x)) x=cdr(x) while (x != NIL) if (is_double) then if (d > num_rvalue(car(x))) then d = num_rvalue(car(x)) else if (isflonum(car(x))) then d = v // 'cast double v' and '(double) v' don't work!!! if (d > rvalue(car(x))) then d = rvalue(car(x)) is_double = 1 else if (v > ivalue(car(x))) then v = ivalue(car(x)) end if end if x = cdr(x) wend goto COMMON1 case OP_MAX x = args 'v = -9223372036854775808 'v=0x7fffffffffffffff 'd = -1 / 0 // LONG_LONG_MIN, -#INF if ((x == NIL)) then Error_0("'max' requires at least one argument") end if v=num_ivalue(car(x)) d=num_rvalue(car(x)) x=cdr(x) while (x != NIL) if (is_double) then if (d < num_rvalue(car(x))) then d = num_rvalue(car(x)) else if (isflonum(car(x))) then d = v // 'cast double v' and '(double) v' don't work!!! if (d < rvalue(car(x))) then d = rvalue(car(x)) is_double = 1 else if (v < ivalue(car(x))) then v = ivalue(car(x)) end if end if x = cdr(x) wend goto COMMON1 // ---- these procs return whole numbers ---- case OP_QUOTNT // quotient (integer division) x = car(args) if ((x == NIL) || (ispair(cdr(args)) == 0) || ispair(cddr(args))) then Error_0("'quotient' requires two arguments") end if d = num_rvalue(cadr(args)) if (d == 0.0) then Error_0("'quotient' is undefined for 0") end if if (isflonum(cadr(args))) then is_double = 1 v = d if (v != d) then // as per r5rs Error_0("'quotient' requires whole numbers") end if end if d = num_rvalue(x) if (isflonum(x)) then is_double = 1 v = d if (v != d) then // ditto Error_0("'quotient' requires whole numbers") end if end if d \= num_rvalue(cadr(args)) goto COMMON2 case OP_REM /* remainder */ // C/BASIC compliant modulo x = car(args) if ((x == NIL) || (ispair(cdr(args)) == 0) || ispair(cddr(args))) then Error_0("'remainder' requires two arguments") end if d = num_rvalue(cadr(args)) if (d == 0.0) then Error_0("'remainder' is undefined for 0") end if if (isflonum(cadr(args))) then is_double = 1 v = d if (v != d) then // as per r5rs Error_0("'remainder' requires whole numbers") end if end if d = num_rvalue(x) if (isflonum(x)) then is_double = 1 v = d if (v != d) then // ditto Error_0("'remainder' requires whole numbers") end if end if d = mod(d, num_rvalue(cadr(args))) goto COMMON2 case OP_MODULO // modulo (Knuth's floored division remainder) x = car(args) if ((x == NIL) || (ispair(cdr(args)) == 0) || ispair(cddr(args))) then Error_0("'modulo' requires two arguments") end if d = num_rvalue(cadr(args)) if (d == 0.0) then Error_0("'modulo' is undefined for 0") end if if (isflonum(cadr(args))) then is_double = 1 v = d if (v != d) then // as per r5rs Error_0("'modulo' requires whole numbers") end if end if d = num_rvalue(x) if (isflonum(x)) then is_double = 1 v = d if (v != d) then // ditto Error_0("'modulo' requires whole numbers") end if end if v = num_ivalue(cadr(args)) d = d - floor(d / v) * v goto COMMON2 case OP_GCD // greatest common denominator (2 args w/o warning only for now) x = car(args) if ((x == NIL)) then d = 0.0 goto COMMON2 end if if (cadr(args) == NIL) then d = abs(num_rvalue(x)) // as per r5rs if (isflonum(x)) then is_double = 1 end if goto COMMON2 end if d = num_rvalue(cadr(args)) if (isflonum(cadr(args))) then is_double = 1 v = d if (v != d) then // as per r5rs Error_0("'gcd' requires whole numbers") end if end if d = num_rvalue(x) if (isflonum(x)) then is_double = 1 v = d if (v != d) then // ditto Error_0("'gcd' requires whole numbers") end if end if v = num_ivalue(cadr(args)) d = gcd(d, v) goto COMMON2 case OP_LCM // least common multiple (2 args w/o warning only for now) x = car(args) if ((x == NIL)) then d = 1.0 goto COMMON2 end if if (cadr(args) == NIL) then d = abs(num_rvalue(x)) // as per r5rs if (isflonum(x)) then is_double = 1 end if goto COMMON2 end if d = num_rvalue(cadr(args)) if (isflonum(cadr(args))) then is_double = 1 v = d if (v != d) then // as per r5rs Error_0("'lcm' requires whole numbers") end if end if d = num_rvalue(x) if (isflonum(x)) then is_double = 1 v = d if (v != d) then // ditto Error_0("'lcm' requires whole numbers") end if end if v = num_ivalue(cadr(args)) d = scm(v, d) goto COMMON2 // ------------------------------------------ // these two functions may faulter at 10^len // with high digit counts due to wild counts // of double's decimals in the str() call. 9 // digits max still perform reasonably well. case OP_NUMER // numerator x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'numerator' requires one argument") end if if (isflonum(x)) then is_double = 1 scope d = num_rvalue(x) string s = str(d) // to count decimal places double dd = 10 ^ len(mid(s, instr(s, ".") + 1)) d *= dd // else gcd(quad, quad) fails! d /= gcd(d, dd) end scope goto COMMON2 case OP_DENOM // denominator x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'denominator' requires one argument") end if if (isflonum(x)) then is_double = 1 scope d = num_rvalue(x) string s = str(d) // to count decimal places double dd = 10 ^ len(mid(s, instr(s, ".") + 1)) d *= dd // else gcd(quad, quad) fails! d = dd / gcd(d, dd) end scope goto COMMON2 // ------------------------------------------ case OP_INEXEX // inexact->exact x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'inexact->exact' requires one argument") end if if (isflonum(x)) then d = rvalue(x) if (d != trunc(d)) then Error_0("'inexact->exact' requires a whole number") end if s_return(mk_integer(d)) end if s_return(mk_integer(ivalue(x))) case OP_EXINEX // exact->inexact x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'exact->inexact' requires one argument") end if if (isflonum(x)) then d = rvalue(x) s_return(mk_real(rvalue(x))) end if s_return(mk_real(num_ivalue(x))) // ------- these procs return flonums ------- case OP_SIN x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'sin' requires one argument") end if d = sin(num_rvalue(x)) s_return(mk_real(d)) case OP_COS x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'cos' requires one argument") end if d = cos(num_rvalue(x)) s_return(mk_real(d)) case OP_TAN x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'tan' requires one argument") end if d = tan(num_rvalue(x)) s_return(mk_real(d)) case OP_ASIN x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'asin' requires one argument") end if d = asin(num_rvalue(x)) s_return(mk_real(d)) case OP_ACOS x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'acos' requires one argument") end if d = acos(num_rvalue(x)) s_return(mk_real(d)) case OP_ATAN // atan2() included x = car(args) if ((x == NIL) || ispair(cddr(args))) then Error_0("'atan' requires one or two arguments") end if if (ispair(cdr(args))) then d = atan(num_rvalue(x), num_rvalue(cadr(args))) else d = atn(num_rvalue(x)) end if s_return(mk_real(d)) case OP_EXP x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'exp' requires one argument") end if d = exp(num_rvalue(x)) s_return(mk_real(d)) case OP_LOG x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'log' requires one argument") end if d = num_rvalue(x) if (d == 0.0) then Error_0("'log' is undefined for 0") end if d = log(d) s_return(mk_real(d)) case OP_SQRT x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'sqrt' requires one argument") end if d = sqrt(num_rvalue(x)) if (d < 0.0) then Error_0("'sqrt' is undefined for less than 0") // no complex numbers yet! end if s_return(mk_real(d)) // ------------------------------------------ case OP_EXPT // pow(x,y) x = car(args) if ((x == NIL) || (ispair(cdr(args)) == 0) || ispair(cddr(args))) then Error_0("'expt' requires two arguments") end if d = num_rvalue(x) if (d == 0.0) then // as per r5rs if (num_rvalue(cadr(args)) == 0.0) then s_return(mk_real(1.0)) else s_return(mk_real(0.0)) end if end if d = pow(num_rvalue(x), num_rvalue(cadr(args))) if (isfixnum(x) && isfixnum(cadr(args))) then // as per r5rs s_return(mk_integer(d)) end if s_return(mk_real(d)) // ---- these procs return whole numbers ---- case OP_FLOOR x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'floor' requires one argument") end if if (isflonum(x)) then is_double = 1 d = floor(num_rvalue(x)) goto COMMON2 case OP_CEIL x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'ceiling' requires one argument") end if if (isflonum(x)) then is_double = 1 d = ceil(num_rvalue(x)) goto COMMON2 case OP_TRUNC x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'truncate' requires one argument") end if if (isflonum(x)) then is_double = 1 d = trunc(num_rvalue(x)) goto COMMON2 case OP_ROUND x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'round' requires one argument") end if if (isflonum(x)) then is_double = 1 d = round(num_rvalue(x)) goto COMMON2 // ------------------------------------------ case OP_CAR /* car */ if (ispair(car(args))) then s_return(caar(args)) end if Error_0("unable to car a non-pair element") case OP_CDR /* cdr */ if (ispair(car(args))) then s_return(cdar(args)) end if Error_0("unable to cdr a non-pair element") case OP_CONS /* cons */ cdr(args) = cadr(args) s_return(args) case OP_SETCAR /* set-car! */ if (ispair(car(args))) then caar(args) = cadr(args) s_return(car(args)) end if Error_0("unable to set-car! a non-pair element") case OP_SETCDR /* set-cdr! */ if (ispair(car(args))) then cdar(args) = cadr(args) s_return(car(args)) end if Error_0("unable to set-cdr! a non-pair element") case else sprintf(strbuff, "%d is an illegal operator", operator) Error_0(strbuff) end select return T COMMON1: if (is_double) then s_return(mk_real(d)) end if s_return(mk_integer(v)) return T COMMON2: if (is_double) then s_return(mk_real(d)) end if s_return(mk_integer(d)) return T end function function opexe_3(int op) as sys, label sys x double d select case op case OP_NOT /* not */ if (car(args) == F || car(args) == T) then // as per r5rs s_retbool(isfalse(car(args))) end if s_retbool(0) case OP_BOOL /* boolean? */ s_retbool(car(args) == F || car(args) == T) case OP_NULL /* null? */ s_retbool(car(args) == NIL) case OP_ZEROP /* zero? */ if (isflonum(car(args))) then s_retbool(rvalue(car(args)) == 0.0) end if s_retbool(ivalue(car(args)) == 0) case OP_POSP /* positive? */ if (isflonum(car(args))) then s_retbool(rvalue(car(args)) >= 0.0) end if s_retbool(ivalue(car(args)) >= 0) case OP_NEGP /* negative? */ if (isflonum(car(args))) then s_retbool(rvalue(car(args)) < 0.0) end if s_retbool(ivalue(car(args)) < 0) case OP_ODDP if (isflonum(car(args))) then d = rvalue(car(args)) if (d != trunc(d)) then Error_0("'odd?' requires a whole number") end if s_retbool(mod(d, 2.0) != 0.0) end if s_retbool(mod(ivalue(car(args)), 2) != 0) case OP_EVNP if (isflonum(car(args))) then d = rvalue(car(args)) if (d != trunc(d)) then Error_0("'even?' requires a whole number") end if s_retbool(mod(d, 2.0) == 0.0) end if s_retbool(mod(ivalue(car(args)), 2) == 0) case OP_NEQ /* = */ // must be transitive (multi-argument) as per r5rs x = args d = num_rvalue(car(x)) while (x != NIL && cdr(x) != NIL) if (d != num_rvalue(cadr(x))) then s_retbool(0) end if x = cdr(x) wend s_retbool(1) // s_retbool(num_rvalue(car(args)) == num_rvalue(cadr(args))) case OP_LESS /* < */ // ditto x = args d = num_rvalue(car(x)) while (x != NIL && cdr(x) != NIL) if (d >= num_rvalue(cadr(x))) then s_retbool(0) end if x = cdr(x) d = num_rvalue(car(x)) wend s_retbool(1) // s_retbool(num_rvalue(car(args)) < num_rvalue(cadr(args))) case OP_GRE /* > */ // ditto x = args d = num_rvalue(car(x)) while (x != NIL && cdr(x) != NIL) if (d <= num_rvalue(cadr(x))) then s_retbool(0) end if x = cdr(x) d = num_rvalue(car(x)) wend s_retbool(1) // s_retbool(num_rvalue(car(args)) > num_rvalue(cadr(args))) case OP_LEQ /* <= */ // ditto x = args d = num_rvalue(car(x)) while (x != NIL && cdr(x) != NIL) if (d > num_rvalue(cadr(x))) then s_retbool(0) end if x = cdr(x) d = num_rvalue(car(x)) wend s_retbool(1) // s_retbool(num_rvalue(car(args)) <= num_rvalue(cadr(args))) case OP_GEQ /* >= */ // ditto x = args d = num_rvalue(car(x)) while (x != NIL && cdr(x) != NIL) if (d < num_rvalue(cadr(x))) then s_retbool(0) end if x = cdr(x) d = num_rvalue(car(x)) wend s_retbool(1) // s_retbool(num_rvalue(car(args)) >= num_rvalue(cadr(args))) case OP_SYMBOL /* symbol? */ s_retbool(issymbol(car(args))) case OP_NUMBER, OP_RATIONAL, OP_REAL, OP_COMPLEX /* number? */ s_retbool(isnumber(car(args))) case OP_INTEGER // as per r5rs !!! s_retbool(isnumber(car(args)) && (isflint(car(args)) || isfixnum(car(args)))) case OP_EXACT // no other exact numbers yet s_retbool(isfixnum(car(args))) case OP_INEXACT s_retbool(isflonum(car(args))) case OP_STRING /* string? */ s_retbool(isstring(car(args))) case OP_PROC /* procedure? */ /*-- * continuation should be procedure by the example * (call-with-current-continuation procedure?) ==> #t * in R^3 report sec. 6.9 */ s_retbool(isproc(car(args)) || isclosure(car(args)) || iscontinuation(car(args))) case OP_PAIR /* pair? */ s_retbool(ispair(car(args))) case OP_EQ /* eq? */ s_retbool(car(args) == cadr(args)) case OP_EQV /* eqv? */ s_retbool(eqv(car(args), cadr(args))) case else sprintf(strbuff, "%d is an illegal operator", operator) Error_0(strbuff) end select return T end function function opexe_4(int op) as sys, label sys x, y int was select case op case OP_FORCE /* force */ code = car(args) if (ispromise(code)) then args = NIL s_goto(OP_APPLY) end if s_return(code) case OP_WRITE /* write */ print_flag = 1 args = car(args) s_goto(OP_P0LIST) case OP_DISPLAY /* display */ print_flag = 0 args = car(args) s_goto(OP_P0LIST) case OP_NEWLINE /* newline */ fprintf(outfp, cr) // "\n" s_return(T) case OP_ERR0 /* error */ if (isstring(car(args)) == 0) then Error_0("first argument must be a string") end if tmpfp = outfp outfp = stderr fprintf(outfp, "Error: ") fprintf(outfp, "%s", strvalue(car(args))) args = cdr(args) s_goto(OP_ERR1) case OP_ERR1 /* error */ fprintf(outfp, " ") if (args != NIL) then s_save(OP_ERR1, cdr(args), NIL) args = car(args) print_flag = 1 s_goto(OP_P0LIST) end if fprintf(outfp, cr) // "\n" flushinput() outfp = tmpfp s_goto(OP_T0LVL) case OP_REVERSE /* reverse */ s_return(reverse(car(args))) case OP_APPEND /* append */ s_return(append(car(args), cadr(args))) case OP_PUT /* put */ if ((hasprop(car(args)) == 0) || (hasprop(cadr(args)) == 0)) then Error_0("illegal use of 'put'") end if x = symprop(car(args)) y = cadr(args) while (x != NIL) if (caar(x) == y) then exit while x = cdr(x) wend if (x != NIL) then cdar(x) = caddr(args) else symprop(car(args)) = cons(cons(y, caddr(args)), symprop(car(args))) end if s_return(T) case OP_GET /* get */ if ((hasprop(car(args)) == 0) || (hasprop(cadr(args)) == 0)) then Error_0("illegal use of 'get'") end if x = symprop(car(args)) y = cadr(args) while (x != NIL) if (caar(x) == y) then exit while x = cdr(x) wend if (x != NIL) then s_return(cdar(x)) end if s_return(NIL) case OP_QUIT /* quit */ return NIL case OP_GC /* gc */ gc(NIL, NIL) s_return(T) case OP_GCVERB /* gc-verbose */ was = gc_verbose gc_verbose = (car(args) != F) s_retbool(was) case OP_NEWSEGMENT /* new-segment */ if (isfixnum(car(args)) == 0) then Error_0("argument must be a number") end if fprintf(outfp, "allocate %d new segments%s", alloc_cellseg((int) ivalue(car(args))), cr) s_return(T) case else sprintf(strbuff, "%d is an illegal operator", operator) Error_0(strbuff) end select return T end function function opexe_5(sys op) as sys, label sys x select case op /* ========== reading part ========== */ case OP_RDSEXPR: select case tok case TOK_EOF s_return(EOF_OBJ) case TOK_COMMENT while (inchar() != 0xA) // '\n' wend tok = token() s_goto(OP_RDSEXPR) case TOK_LPAREN tok = token() if (tok == TOK_RPAREN) then s_return(NIL) else if (tok == TOK_DOT) then Error_0("illegal dot expression") end if s_save(OP_RDLIST, NIL, NIL) s_goto(OP_RDSEXPR) case TOK_QUOTE s_save(OP_RDQUOTE, NIL, NIL) tok = token() s_goto(OP_RDSEXPR) case TOK_BQUOTE s_save(OP_RDQQUOTE, NIL, NIL) tok = token() s_goto(OP_RDSEXPR) case TOK_COMMA s_save(OP_RDUNQUOTE, NIL, NIL) tok = token() s_goto(OP_RDSEXPR) case TOK_ATMARK s_save(OP_RDUQTSP, NIL, NIL) tok = token() s_goto(OP_RDSEXPR) case TOK_ATOM s_return(mk_atom(readstr("(); " & chr(0xA)))) // "();\t\n " case TOK_DQUOTE: s_return(mk_string(readstrexp())) case TOK_SHARP x = mk_const(readstr("(); " & chr(0xA))) // "();\t\n " if (x == NIL) then Error_0("undefined sharp expression") end if s_return(x) case else Error_0("illegal token") end select case OP_RDLIST args = cons(value, args) tok = token() if (tok == TOK_COMMENT) then while (inchar() != 0xA) // '\n' // eat to EOL wend tok = token() end if if (tok == TOK_RPAREN) then s_return(non_alloc_rev(NIL, args)) else if (tok == TOK_DOT) then s_save(OP_RDDOT, args, NIL) tok = token() s_goto(OP_RDSEXPR) end if s_save(OP_RDLIST, args, NIL) s_goto(OP_RDSEXPR) case OP_RDDOT if (token() != TOK_RPAREN) then Error_0("illegal dot expression") end if s_return(non_alloc_rev(value, args)) case OP_RDQUOTE s_return(cons(SQUOTE, cons(value, NIL))) case OP_RDQQUOTE s_return(cons(QQUOTE, cons(value, NIL))) case OP_RDUNQUOTE s_return(cons(UNQUOTE, cons(value, NIL))) case OP_RDUQTSP s_return(cons(UNQUOTESP, cons(value, NIL))) /* ========== printing part ========== */ case OP_P0LIST if (ispair(args) == 0) then printatom(args, print_flag) s_return(T) else if ((car(args) == SQUOTE) && ok_abbrev(cdr(args))) then fprintf(outfp, "'") args = cadr(args) s_goto(OP_P0LIST) else if ((car(args) == QQUOTE) && ok_abbrev(cdr(args))) then fprintf(outfp, chr(BACKQUOTE)) args = cadr(args) s_goto(OP_P0LIST) else if ((car(args) == UNQUOTE) && ok_abbrev(cdr(args))) then fprintf(outfp, ",") args = cadr(args) s_goto(OP_P0LIST) else if ((car(args) == UNQUOTESP) && ok_abbrev(cdr(args))) then fprintf(outfp, ",@") args = cadr(args) s_goto(OP_P0LIST) end if fprintf(outfp, "(") s_save(OP_P1LIST, cdr(args), NIL) args = car(args) s_goto(OP_P0LIST) case OP_P1LIST if (ispair(args)) then s_save(OP_P1LIST, cdr(args), NIL) fprintf(outfp, " ") args = car(args) s_goto(OP_P0LIST) end if if (args != NIL) then fprintf(outfp, " . ") printatom(args, print_flag) end if fprintf(outfp, ")") s_return(T) case else sprintf(strbuff, "%d is an illegal operator", operator) Error_0(strbuff) end select return T end function function opexe_6(sys op) as sys, label sys x, y long v static long w select case op case OP_IS_LIST s_retbool(list_length(car(args)) >= 0) case OP_LIST_LENGTH v = list_length(car(args)) if (v < 0) then Error_0("argument must be a list") end if s_return(mk_number(v)) case OP_ASSQ /* assq *//* a.k */ x = car(args) y = cadr(args) while (ispair(y)) if (ispair(car(y)) == 0) then Error_0("unable to assq a non-pair element") end if if (x == caar(y)) then exit while y = cdr(y) wend if (ispair(y)) then s_return(car(y)) end if s_return(F) case OP_PRINT_WIDTH /* print-width *//* a.k */ w = 0 args = car(args) print_flag = -1 s_goto(OP_P0_WIDTH) case OP_P0_WIDTH if (ispair(args) == 0) then w += printatom(args, print_flag) s_return(mk_number(w)) else if (car(args) == SQUOTE && ok_abbrev(cdr(args))) then w++ args = cadr(args) s_goto(OP_P0_WIDTH) else if (car(args) == QQUOTE && ok_abbrev(cdr(args))) then w++ args = cadr(args) s_goto(OP_P0_WIDTH) else if (car(args) == UNQUOTE && ok_abbrev(cdr(args))) then w++ args = cadr(args) s_goto(OP_P0_WIDTH) else if (car(args) == UNQUOTESP && ok_abbrev(cdr(args))) then w += 2 args = cadr(args) s_goto(OP_P0_WIDTH) else w++ s_save(OP_P1_WIDTH, cdr(args), NIL) args = car(args) s_goto(OP_P0_WIDTH) end if case OP_P1_WIDTH: if (ispair(args)) then s_save(OP_P1_WIDTH, cdr(args), NIL) w++ args = car(args) s_goto(OP_P0_WIDTH) end if if (args != NIL) then w += 3 + printatom(args, print_flag) end if w++ s_return(mk_number(w)) case OP_GET_CLOSURE /* get-closure-code *//* a.k */ args = car(args) if (args == NIL) then s_return(F) else if (isclosure(args)) then s_return(cons(LAMBDA, closure_code(value))) else if (ismacro(args)) then s_return(cons(LAMBDA, closure_code(value))) end if s_return(F) case OP_CLOSUREP /* closure? */ /* * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t */ if (car(args) == NIL) then s_return(F) end if s_retbool(isclosure(car(args))) case OP_MACROP /* macro? */ if (car(args) == NIL) then s_return(F) end if s_retbool(ismacro(car(args))) case else sprintf(strbuff, "%d is an illegal operator", operator) Error_0(strbuff) end select return T /* NOTREACHED */ end function // strings function opexe_7(sys op) as sys, label sys x, y, z, l char s[128] select case op case OP_NUMSTR // number->string x = car(args) if ((x == NIL) || ispair(cddr(args))) then Error_0("'number->string' requires one or two arguments") end if if (isflonum(x)) then // as per r5rs if (isflint(x)) then sprintf(s, "%I64d.0", num_ivalue(x)) else sprintf(s, "%.15g", rvalue(x)) end if else if (ispair(cdr(args)) == 0) then sprintf(s, "%I64d", ivalue(x)) else // radix given sys v = isfixnum(cadr(args)) if (v == 0) then v = isflint(cadr(args)) if (v == 0) then Error_0("radix must be a whole number") end if end if scope byte radix = num_ivalue(cadr(args)) select case radix case 2 v = ivalue(x) x = strptr(s) _i64toa(v, x, 2) case 8 sprintf(s, "%I64o", ivalue(x)) case 10 sprintf(s, "%I64d", ivalue(x)) case 16 sprintf(s, "%I64x", ivalue(x)) case else Error_0("radix must be 2, 8, 10, or 16") end select end scope end if s_return(mk_string(s)) case OP_STRNUM // string->number x = car(args) if ((x == NIL) || ispair(cddr(args))) then Error_0("'string->number' requires one or two arguments") end if sprintf(s, "%s", strvalue(x)) v = instr(s, "#") if (v == 0) then s_return(mk_atom(s)) end if scope byte b at @s while (b != 0) // overwrite leading '#' 'b = (byte)*(@b + 1) b[1]=b[2] @b++ wend end scope x = mk_const(s) if (x == NIL) then // as per r5rs s_retbool(0) end if s_return(x) case OP_SYMSTR x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'symbol->string' requires one argument") end if if (issymbol(x) == 0) then Error_0("argument must be a symbol") end if sprintf(s, "%s", strvalue(car(x))) s_return(mk_string(s)) case OP_STRSYM x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'string->symbol' requires one argument") end if if (isstring(x) == 0) then Error_0("argument must be a string") end if sprintf(s, "%s", strvalue(x)) s_return(mk_symbol(s)) case OP_MKSTR x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'make-string' requires one argument") // chars aren't implemented yet end if if (isnumber(x) == 0) then Error_0("argument must be a number") end if y = trunc(num_rvalue(x)) if (y != num_rvalue(x)) then Error_0("argument must be a whole number") end if s_return(mk_string(space(y))) // filled w/ spaces case OP_STRLEN x = car(args) if ((x == NIL) || ispair(cdr(args))) then Error_0("'string-length' requires one argument") end if if (isstring(x) == 0) then Error_0("argument must be a string") end if s_return(mk_number(strlen(strvalue(x)))) case OP_STREQ to OP_STRGEQ x = car(args) if ((x == NIL) || (ispair(cdr(args)) == 0) || ispair(cddr(args))) then Error_0("two arguments are expected") end if if ((isstring(x) == 0) || (isstring(cadr(args)) == 0)) then Error_0("arguments must be strings") end if x = strvalue(x): y = strvalue(cadr(args)) x=strcmp x,y if (op == OP_STREQ) then s_retbool(x == 0) else if (op == OP_STRLS) then s_retbool(x < 0) else if (op == OP_STRGT) then s_retbool(x > 0) else if (op <= OP_STRLEQ) then s_retbool(x <= 0) else // op == OP_STRGEQ s_retbool(x >= 0) end if case OP_STREQI to OP_STRGEQI x = car(args) if ((x == NIL) || (ispair(cdr(args)) == 0) || ispair(cddr(args))) then Error_0("two arguments are expected") end if if ((isstring(x) == 0) || (isstring(cadr(args)) == 0)) then Error_0("arguments must be strings") end if x = strvalue(x): y = strvalue(cadr(args)) x = _strcmpi x,y if (op == OP_STREQ) then s_retbool(x == 0) else if (op == OP_STRLS) then s_retbool(x < 0) else if (op == OP_STRGT) then s_retbool(x > 0) else if (op <= OP_STRLEQ) then s_retbool(x <= 0) else // op == OP_STRGEQ s_retbool(x >= 0) end if case OP_SUBSTR // a-la mid() but not quite x = car(args) if ((x == NIL) || (ispair(cdr(args)) == 0) _ || (ispair(cddr(args)) == 0) || ispair(cdddr(args))) then Error_0("'substring' requires three arguments") end if y = cadr(args) z = caddr(args) if (isstring(x) == 0) then Error_0("1st argument must be a string") end if if (isnumber(y) == 0) then Error_0("2nd argument must be a number") end if if (isnumber(z) == 0) then Error_0("3rd argument must be a number") end if y = trunc(num_rvalue(y)) z = trunc(num_rvalue(z)) if (y != num_rvalue(cadr(args))) then Error_0("2nd argument must be a whole number") end if if (z != num_rvalue(caddr(args))) then Error_0("3rd argument must be a whole number") end if l = strlen(strvalue(x)) if ((y < 0) || (z < y) || (l < z)) then // as per r5rs Error_0("invalid numeric argument(s)") end if scope // Arrrgh... HOW TO CAST BLOODY *cell TO CHAR* FOR MID()?! l = z - y // exclusive of 'end' as per r5rs string chunk = space(l) memcpy(strptr(chunk), strvalue(x) + y, l) s_return(mk_string(chunk)) end scope case OP_STRAPP // concatenation x = args if (x == NIL) then Error_0("'string-append' requires at least one argument") end if while (x != NIL) if (isstring(car(x)) == 0) then Error_0("'string-append' requires string arguments") end if l = strlen(strvalue(car(x))) if (y) then z = strlen(y) y = realloc(y, l + z + 1) // AGAIN HOW TO CAST ARBITRARY VALUE TO CHAR*?! memcpy(y + z, strvalue(car(x)), l) (byte)*(y + l + z) = 0 // null-terminate x = cdr(x) wend push y call mk_string mov x, eax free(y) s_return(x) case else sprintf(strbuff, "%d is an illegal operator", operator) Error_0(strbuff) end select return T end function sys dispatch_table[] = { &opexe_0, /* OP_LOAD = 0, */ &opexe_0, /* OP_T0LVL, */ &opexe_0, /* OP_T1LVL, */ &opexe_0, // OP_GENSYM &opexe_0, /* OP_READ, */ &opexe_0, /* OP_VALUEPRINT, */ &opexe_0, /* OP_EVAL, */ &opexe_0, /* OP_E0ARGS, */ &opexe_0, /* OP_E1ARGS, */ &opexe_0, /* OP_APPLY, */ &opexe_0, /* OP_DOMACRO, */ &opexe_0, /* OP_LAMBDA, */ &opexe_0, /* OP_QUOTE, */ &opexe_0, /* OP_DEF0, */ &opexe_0, /* OP_DEF1, */ &opexe_0, /* OP_BEGIN, */ &opexe_0, /* OP_IF0, */ &opexe_0, /* OP_IF1, */ &opexe_0, /* OP_SET0, */ &opexe_0, /* OP_SET1, */ &opexe_0, /* OP_LET0, */ &opexe_0, /* OP_LET1, */ &opexe_0, /* OP_LET2, */ &opexe_0, /* OP_LET0AST, */ &opexe_0, /* OP_LET1AST, */ &opexe_0, /* OP_LET2AST, */ &opexe_1, /* OP_LET0REC, */ &opexe_1, /* OP_LET1REC, */ &opexe_1, /* OP_LETREC2, */ &opexe_1, /* OP_COND0, */ &opexe_1, /* OP_COND1, */ &opexe_1, /* OP_DELAY, */ &opexe_1, /* OP_AND0, */ &opexe_1, /* OP_AND1, */ &opexe_1, /* OP_OR0, */ &opexe_1, /* OP_OR1, */ &opexe_1, /* OP_C0STREAM, */ &opexe_1, /* OP_C1STREAM, */ &opexe_1, /* OP_0MACRO, */ &opexe_1, /* OP_1MACRO, */ &opexe_1, /* OP_CASE0, */ &opexe_1, /* OP_CASE1, */ &opexe_1, /* OP_CASE2, */ &opexe_1, /* OP_PEVAL, */ &opexe_1, /* OP_PAPPLY, */ &opexe_1, /* OP_CONTINUATION, */ &opexe_2, /* OP_ADD, */ &opexe_2, /* OP_SUB, */ &opexe_2, /* OP_MUL, */ &opexe_2, /* OP_DIV, */ &opexe_2, /* OP_ABS, */ &opexe_2, /* OP_MIN, */ &opexe_2, /* OP_MAX, */ &opexe_2, /* OP_QUOTNT, */ &opexe_2, /* OP_REM, */ &opexe_2, /* OP_MODULO, */ &opexe_2, /* OP_GCD, */ &opexe_2, /* OP_LCM, */ &opexe_2, /* OP_NUMER, */ &opexe_2, /* OP_DENOM, */ &opexe_2, /* OP_INEXEX, */ &opexe_2, /* OP_EXINEX, */ &opexe_2, /* OP_SIN, */ &opexe_2, /* OP_COS, */ &opexe_2, /* OP_TAN, */ &opexe_2, /* OP_ASIN, */ &opexe_2, /* OP_ACOS, */ &opexe_2, /* OP_ATAN, */ &opexe_2, /* OP_EXP, */ &opexe_2, /* OP_LOG, */ &opexe_2, /* OP_SQRT, */ &opexe_2, /* OP_EXPT, */ &opexe_2, /* OP_FLOOR, */ &opexe_2, /* OP_CEIL, */ &opexe_2, /* OP_TRUNC, */ &opexe_2, /* OP_ROUND, */ &opexe_2, /* OP_CAR, */ &opexe_2, /* OP_CDR, */ &opexe_2, /* OP_CONS, */ &opexe_2, /* OP_SETCAR, */ &opexe_2, /* OP_SETCDR, */ &opexe_3, /* OP_NOT, */ &opexe_3, /* OP_BOOL, */ &opexe_3, /* OP_NULL, */ &opexe_3, /* OP_ZEROP, */ &opexe_3, /* OP_POSP, */ &opexe_3, /* OP_NEGP, */ &opexe_3, /* OP_ODDP, */ &opexe_3, /* OP_EVNP, */ &opexe_3, /* OP_NEQ, */ &opexe_3, /* OP_LESS, */ &opexe_3, /* OP_GRE, */ &opexe_3, /* OP_LEQ, */ &opexe_3, /* OP_GEQ, */ &opexe_3, /* OP_SYMBOL, */ &opexe_3, /* OP_NUMBER, */ &opexe_3, /* OP_INTEGER, */ &opexe_3, /* OP_RATIONAL, */ &opexe_3, /* OP_REAL, */ &opexe_3, /* OP_COMPLEX, */ &opexe_3, /* OP_EXACT, */ &opexe_3, /* OP_INEXACT, */ &opexe_3, /* OP_STRING, */ &opexe_3, /* OP_PROC, */ &opexe_3, /* OP_PAIR, */ &opexe_3, /* OP_EQ, */ &opexe_3, /* OP_EQV, */ &opexe_4, /* OP_FORCE, */ &opexe_4, /* OP_WRITE, */ &opexe_4, /* OP_DISPLAY, */ &opexe_4, /* OP_NEWLINE, */ &opexe_4, /* OP_ERR0, */ &opexe_4, /* OP_ERR1, */ &opexe_4, /* OP_REVERSE, */ &opexe_4, /* OP_APPEND, */ &opexe_4, /* OP_PUT, */ &opexe_4, /* OP_GET, */ &opexe_4, /* OP_QUIT, */ &opexe_4, /* OP_GC, */ &opexe_4, /* OP_GCVERB, */ &opexe_4, /* OP_NEWSEGMENT, */ &opexe_5, /* OP_RDSEXPR, */ &opexe_5, /* OP_RDLIST, */ &opexe_5, /* OP_RDDOT, */ &opexe_5, /* OP_RDQUOTE, */ &opexe_5, /* OP_RDQQUOTE, */ &opexe_5, /* OP_RDUNQUOTE, */ &opexe_5, /* OP_RDUQTSP, */ &opexe_5, /* OP_P0LIST, */ &opexe_5, /* OP_P1LIST, */ &opexe_6, /* OP_IS_LIST, */ &opexe_6, /* OP_LIST_LENGTH, */ &opexe_6, /* OP_ASSQ, */ &opexe_6, /* OP_PRINT_WIDTH, */ &opexe_6, /* OP_P0_WIDTH, */ &opexe_6, /* OP_P1_WIDTH, */ &opexe_6, /* OP_GET_CLOSURE, */ &opexe_6, /* OP_CLOSUREP, */ &opexe_6, /* OP_MACROP, */ &opexe_7, /* OP_NUMSTR, */ &opexe_7, /* OP_STRNUM, */ &opexe_7, /* OP_SYMSTR, */ &opexe_7, /* OP_STRSYM, */ &opexe_7, /* OP_MKSTR, */ &opexe_7, /* OP_STRLEN, */ &opexe_7, /* OP_STREQ, */ &opexe_7, /* OP_STRLS, */ &opexe_7, /* OP_STRGT, */ &opexe_7, /* OP_STRLEQ, */ &opexe_7, /* OP_STRGEQ, */ &opexe_7, /* OP_STREQI, */ &opexe_7, /* OP_STRLSI, */ &opexe_7, /* OP_STRGTI, */ &opexe_7, /* OP_STRLEQI, */ &opexe_7, /* OP_STRGEQI, */ &opexe_7, /* OP_SUBSTR, */ &opexe_7 /* OP_STRAPP, */ } /* kernel of this intepreter */ function Eval_Cycle(sys op) as sys sys retval operator = op do 'push operator 'call dispatch_table[operator] '= retval 'if (retval == NIL) then return NIL retval=call dispatch_table[operator] (operator) end do end function /* ========== Initialization of internal keywords ========== */ sub mk_syntax(sys op, char* name) ================================= sys x x = cons(mk_string(name), NIL) flag(x) = (T_SYNTAX | T_SYMBOL) syntaxnum(x) = op oblist = cons(x, oblist) end sub sub mk_proc(sys op, char* name) =============================== sys x, y x = mk_symbol(name) y = get_cell(NIL, NIL) flag(y) = (T_PROC | T_ATOM) ivalue(y) = op car(global_env) = cons(cons(x, y), car(global_env)) end sub sub init_vars_global() ====================== sys x /* init input/output file */ infp = stdin outfp = stdout /* init NIL */ flag(NIL) = (T_ATOM | DOMARK) car(NIL) = cdr(NIL) := NIL /* init T */ flag(T) = (T_ATOM | DOMARK) car(T) = cdr(T) := T /* init F */ flag(F) = (T_ATOM | DOMARK) car(F) = cdr(F) := F /* init EOF_OBJ */ flag(EOF_OBJ) = (T_ATOM | DOMARK) car(EOF_OBJ) = cdr(EOF_OBJ) := EOF_OBJ /* init global_env */ global_env = cons(NIL, NIL) /* init else */ x = mk_symbol("else") car(global_env) = cons(cons(x, T), car(global_env)) end sub sub init_syntax() ================= /* init syntax */ mk_syntax(OP_LAMBDA, "lambda") mk_syntax(OP_QUOTE, "quote") mk_syntax(OP_DEF0, "define") mk_syntax(OP_IF0, "if") mk_syntax(OP_BEGIN, "begin") mk_syntax(OP_SET0, "set!") mk_syntax(OP_LET0, "let") mk_syntax(OP_LET0AST, "let*") mk_syntax(OP_LET0REC, "letrec") mk_syntax(OP_COND0, "cond") mk_syntax(OP_DELAY, "delay") mk_syntax(OP_AND0, "and") mk_syntax(OP_OR0, "or") mk_syntax(OP_C0STREAM, "cons-stream") mk_syntax(OP_0MACRO, "macro") mk_syntax(OP_CASE0, "case") end sub sub init_procs() ================ /* init procedure */ mk_proc(OP_PEVAL, "eval") mk_proc(OP_PAPPLY, "apply") mk_proc(OP_CONTINUATION, "call-with-current-continuation") mk_proc(OP_FORCE, "force") mk_proc(OP_CAR, "car") mk_proc(OP_CDR, "cdr") mk_proc(OP_CONS, "cons") mk_proc(OP_SETCAR, "set-car!") mk_proc(OP_SETCDR, "set-cdr!") mk_proc(OP_ADD, "+") mk_proc(OP_SUB, "-") mk_proc(OP_MUL, "*") mk_proc(OP_DIV, "/") mk_proc(OP_ABS, "abs") mk_proc(OP_MIN, "min") mk_proc(OP_MAX, "max") mk_proc(OP_QUOTNT, "quotient") mk_proc(OP_REM, "remainder") mk_proc(OP_MODULO, "modulo") mk_proc(OP_GCD, "gcd") mk_proc(OP_LCM, "lcm") mk_proc(OP_NUMER, "numerator") mk_proc(OP_DENOM, "denominator") mk_proc(OP_INEXEX, "inexact->exact") mk_proc(OP_EXINEX, "exact->inexact") mk_proc(OP_SIN, "sin") mk_proc(OP_COS, "cos") mk_proc(OP_TAN, "tan") mk_proc(OP_ASIN, "asin") mk_proc(OP_ACOS, "acos") mk_proc(OP_ATAN, "atan") mk_proc(OP_EXP, "exp") mk_proc(OP_LOG, "log") mk_proc(OP_SQRT, "sqrt") mk_proc(OP_EXPT, "expt") mk_proc(OP_FLOOR, "floor") mk_proc(OP_CEIL, "ceiling") mk_proc(OP_TRUNC, "truncate") mk_proc(OP_ROUND, "round") mk_proc(OP_NOT, "not") mk_proc(OP_BOOL, "boolean?") mk_proc(OP_SYMBOL, "symbol?") mk_proc(OP_NUMBER, "number?") mk_proc(OP_INTEGER, "integer?") mk_proc(OP_RATIONAL, "rational?") mk_proc(OP_REAL, "real?") mk_proc(OP_COMPLEX, "complex?") mk_proc(OP_EXACT, "exact?") mk_proc(OP_INEXACT, "inexact?") mk_proc(OP_STRING, "string?") mk_proc(OP_PROC, "procedure?") mk_proc(OP_PAIR, "pair?") mk_proc(OP_EQV, "eqv?") mk_proc(OP_EQ, "eq?") mk_proc(OP_NULL, "null?") mk_proc(OP_ZEROP, "zero?") mk_proc(OP_POSP, "positive?") mk_proc(OP_NEGP, "negative?") mk_proc(OP_ODDP, "odd?") mk_proc(OP_EVNP, "even?") mk_proc(OP_NEQ, "=") mk_proc(OP_LESS, "<") mk_proc(OP_GRE, ">") mk_proc(OP_LEQ, "<=") mk_proc(OP_GEQ, ">=") mk_proc(OP_READ, "read") mk_proc(OP_WRITE, "write") mk_proc(OP_DISPLAY, "display") mk_proc(OP_NEWLINE, "newline") mk_proc(OP_LOAD, "load") mk_proc(OP_GENSYM, "gensym") mk_proc(OP_ERR0, "error") mk_proc(OP_REVERSE, "reverse") mk_proc(OP_APPEND, "append") mk_proc(OP_PUT, "put") mk_proc(OP_GET, "get") mk_proc(OP_GC, "gc") mk_proc(OP_GCVERB, "gc-verbose") mk_proc(OP_NEWSEGMENT, "new-segment") mk_proc(OP_IS_LIST, "list?") mk_proc(OP_LIST_LENGTH, "length") mk_proc(OP_ASSQ, "assq") /* a.k */ mk_proc(OP_PRINT_WIDTH, "print-width") /* a.k */ mk_proc(OP_GET_CLOSURE, "get-closure-code") /* a.k */ mk_proc(OP_CLOSUREP, "closure?") /* a.k */ mk_proc(OP_MACROP, "macro?") /* a.k */ mk_proc(OP_NUMSTR, "number->string") mk_proc(OP_STRNUM, "string->number") mk_proc(OP_SYMSTR, "symbol->string") mk_proc(OP_STRSYM, "string->symbol") mk_proc(OP_MKSTR, "make-string") mk_proc(OP_STRLEN, "string-length") mk_proc(OP_STREQ, "string=?") mk_proc(OP_STRLS, "string?") mk_proc(OP_STRLEQ, "string<=?") mk_proc(OP_STRGEQ, "string>=?") mk_proc(OP_STREQI, "string-ci=?") mk_proc(OP_STRLSI, "string-ci?") mk_proc(OP_STRLEQI, "string-ci<=?") mk_proc(OP_STRGEQI, "string-ci>=?") mk_proc(OP_SUBSTR, "substring") mk_proc(OP_STRAPP, "string-append") mk_proc(OP_QUIT, "quit") end sub /* initialize several globals */ sub init_globals() ================== init_vars_global() init_syntax() init_procs() /* intialization of global pointers to special symbols */ LAMBDA = mk_symbol("lambda") SQUOTE = mk_symbol("quote") QQUOTE = mk_symbol("quasiquote") UNQUOTE = mk_symbol("unquote") UNQUOTESP = mk_symbol("unquote-splicing") end sub /* initialization of nanoscheme */ sub init_scheme() ================= if (alloc_cellseg(FIRST_CELLSEGS) != FIRST_CELLSEGS) then FatalError("unable to allocate initial cell segments", "", "", "") end if if (alloc_strseg(1) == 0) then FatalError("unable to allocate initial string segments", "", "", "") end if #ifdef VERBOSE gc_verbose = 1 #else gc_verbose = 0 #endif gc_verbose = 1 init_globals() end sub /* ========== Main ========== */ sub main() ========== sys op = OP_LOAD printf(banner) init_scheme() args = cons(mk_string(InitFile), NIL) #ifdef USE_SETJMP op = setjmp(@error_jmp) #endif Eval_Cycle(op) end sub main() end // Math Helpers // gcd (recursive euclidian) function gcd(quad u, v) as quad dim as quad _t if v = 0 then return u ' avoid div by zero _t = mod(u, v) _t = gcd(v, _t) if _t < 0 then return -_t ' abs as per r5rs return _t end function // lcm (recursive euclidian) function scm(quad u, v) as quad dim as quad q, _t if u = 0 then return 0 ' as per r5rs q = u * v _t = gcd(u, v) _t = q / _t if _t < 0 then return -_t ' abs as per r5rs return _t end function // Oxygen Specific Macros .num_ivalue_asm ' 32 bits only! mov eax, [esp + 4] ' first param 'pointer' ( mov ecx, T_FLONUM and ecx, [eax + 8] cmp ecx, T_FIXNUM jnz exit fild qword [eax] ret 4 ) fld qword [eax] // frndint ' rounding makes it much slower than .num_rvalue_asm below ret 4 .num_rvalue_asm ' 32 bits only! mov eax, [esp + 4] ' first param 'pointer' ( mov ecx, T_FLONUM and ecx, [eax + 8] cmp ecx, T_FIXNUM jnz exit fild qword [eax] ret 4 ) fld qword [eax] ret 4