/* KScheme, a BRUTAL EDIT of MiniScheme, by Zak Fenton MMXX * CHANGES from Mini-Scheme 0.85 to KScheme 0.1: * - Fixed up some old-style C code that modern/C++ compilers complain about (mostly changes to function definitions, now compiles in Visual Studio 2019) * - Removed copyrighted parts of init.scm (assuming the sections with copyright notices aren't covered by the public domain dedication in this file) * - Made partly embeddable (all globals now stored in a struct passed between each function, each function now has kscm_ prefix with an extra underscore * for most of them to indicate that it's part of a private API for now) * - Changed name (Mini-Scheme -> KScheme, as in "kernel scheme") * - Maybe more features coming... * * ---------- Mini-Scheme Interpreter Version 0.85 ---------- * * coded by Atsushi Moriwaki (11/5/1989) * * E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp * * THIS SOFTWARE IS IN THE PUBLIC DOMAIN * ------------------------------------ * This software is completely free to copy, modify and/or re-distribute. * But I would appreciate it if you left my name on the code as the author. * */ /*-- * * This version has been modified by Chris Pressey. * current version is 0.85p1 (as yet unreleased) * * This version has been modified by R.C. Secrist. * * Mini-Scheme is now maintained by Akira KIDA. * * This is a revised and modified version by Akira KIDA. * current version is 0.85k4 (15 May 1994) * * Please send suggestions, bug reports and/or requests to: * *-- */ #define KSCM_PLATFORM_BSD //#define KSCM_PLUSPLUS // If KSCM_CONFIG_USE_PRECISE is defined, overflow detection will occur in basic math functions #define KSCM_CONFIG_USE_PRECISE // This just allows unsafe legacy C functions in Visual Studio. It should be disabled and fixed properly but not the highest priority. #define _CRT_SECURE_NO_WARNINGS #ifdef KSCM_PLUSPLUS extern "C" { #endif /* * Here is System declaration. * Please define exactly one symbol in the following section. */ /* #define LSC */ /* LightSpeed C for Macintosh */ /* #define LSC4 */ /* THINK C version 4.0 for Macintosh */ /* #define MPW2 */ /* Macintosh Programmer's Workshop v2.0x */ /* #define KSCM_PLATFORM_BSD */ /* 4.x KSCM_PLATFORM_BSD */ /* #define MSC */ /* Microsoft C Compiler v.4.00 - 7.00 */ /* #define KSCM_PLATFORM_TURBOC */ /* Turbo C compiler v.2.0, or TC++ 1.0 */ /* #define SYSV */ /* System-V, or POSIX */ /* #define KSCM_PLATFORM_VAXC */ /* VAX/VMS KSCM_PLATFORM_VAXC 2.x or later */ /* (automatic) */ #ifdef __BORLANDC__ /* Borland C++ - MS-DOS */ #define KSCM_PLATFORM_TURBOC #endif #ifdef __TURBOC__ /* Turbo C V1.5 - MS-DOS */ #define KSCM_PLATFORM_TURBOC #endif #ifdef mips /* DECstation running OSF/1 */ #define KSCM_PLATFORM_BSD #endif #ifdef __osf__ /* Alpha AXP running OSF/1 */ #define KSCM_PLATFORM_BSD #endif #ifdef __DECC /* Alpha AXP running VMS */ #define KSCM_PLATFORM_VAXC #endif #ifdef _AIX /* RS/6000 running AIX */ #define KSCM_PLATFORM_BSD #endif /* * Define or undefine following symbols as you need. */ // #define VERBOSE /* define this if you want verbose GC */ #define KSCM_CONFIG_AVOID_HACK_LOOP /* define this if your compiler is poor * enougth to complain "do { } while (0)" * construction. */ //#define KSCM_CONFIG_USE_SETJMP /* undef this if you do not want to use setjmp() */ #define KSCM_CONFIG_USE_QQUOTE /* undef this if you do not need quasiquote */ #define KSCM_CONFIG_USE_MACRO /* undef this if you do not need macro */ #define KSCM_CONFIG_USE_PERSIST /* undef this if you do not need persistence */ #define KSCM_CONFIG_USE_PRECISE /* undef this if you do not need overflow detection and precise integer size */ #define KSCM_CONFIG_USE_STRUCTS /* undef this if you do not need additional structure types (buffers & abstractions) */ #define KSCM_CONFIG_USE_FLOATS /* undef this if you do not need floating-point functionality (i.e. undefine this if you're running in kernel mode) */ #define KSCM_CONFIG_USE_OBJECTS /* undef this if you do not need object-oriented/vector features (these are handy but may complicate simple implementations) */ #define KSCM_CONFIG_USE_UTF8 /* undef this if you do not need Unicode support */ //#define KSCM_CONFIG_USE_CONSOLE /* undef this if you do not need extended console functions. */ #ifdef KSCM_CONFIG_USE_CONSOLE #include #include #include #include #include #include #endif #define KSCM_CONFIG_MAXLOADS 20 /* the maximum depth of the load stack */ #ifdef KSCM_CONFIG_USE_PRECISE #include #endif #ifdef KSCM_CONFIG_USE_QQUOTE /*-- * If your machine can't support "forward single quotation character" * i.e., '`', you may have trouble to use backquote. * So use '^' in place of '`'. */ # define BACKQUOTE '`' #endif /* * Basic memory allocation units */ #ifdef KSCM_PLATFORM_TURBOC /* rcs */ #define KSCM_CONFIG_CELL_SEGSIZE 2048 #define KSCM_CONFIG_CELL_NSEGMENT 100 #define KSCM_CONFIG_STR_SEGSIZE 2048 #define KSCM_CONFIG_STR_NSEGMENT 100 #else #define KSCM_CONFIG_CELL_SEGSIZE 10000 /* # of cells in one segment */ #define KSCM_CONFIG_CELL_NSEGMENT 100 /* # of segments for cells */ #define KSCM_CONFIG_STR_SEGSIZE 10000 /* bytes of one string segment */ #define KSCM_CONFIG_STR_NSEGMENT 10000 /* # of segments for strings */ #endif #define KSCM_CONFIG_BANNER "Hello, This is KScheme (kscm) 0.3, based on Mini-Scheme Interpreter Version 0.85p1.\n" #define KSCM_CONFIG_PERSIST_MAGIC "KSCM" #define KSCM_CONFIG_PERSIST_VERSION 2 #include #include #include #ifdef KSCM_CONFIG_USE_SETJMP #include #endif /* System dependency */ #ifdef LSC #include #include #define malloc(x) NewPtr((long)(x)) #define KSCM_CONFIG_PROMPT "> " #define KSCM_CONFIG_INITFILE "init.scm" #define KSCM_CONFIG_FIRST_CELLSEGS 5 #endif #ifdef LSC4 #include #include #define malloc(x) NewPtr((long)(x)) #define KSCM_CONFIG_PROMPT "> " #define KSCM_CONFIG_INITFILE "init.scm" #define KSCM_CONFIG_FIRST_CELLSEGS 5 #endif #ifdef MPW2 #include #include #define malloc(x) NewPtr((long)(x)) #define KSCM_CONFIG_PROMPT "> [enter at next line]\n" #define KSCM_CONFIG_INITFILE "init.scm" #define KSCM_CONFIG_FIRST_CELLSEGS 5 #endif #ifdef KSCM_PLATFORM_BSD #include #include #include #define KSCM_CONFIG_PROMPT "> " #define KSCM_CONFIG_INITFILE "init.scm" #define KSCM_CONFIG_FIRST_CELLSEGS 10 #endif // Old definition, no detection #ifdef MSC #include #include #include #include #define KSCM_CONFIG_PROMPT "> " #define KSCM_CONFIG_INITFILE "init.scm" #define KSCM_CONFIG_FIRST_CELLSEGS 3 #endif #ifdef KSCM_PLATFORM_TURBOC #include #include #define KSCM_CONFIG_PROMPT "> " #define KSCM_CONFIG_INITFILE "init.scm" #define KSCM_CONFIG_FIRST_CELLSEGS 3 #endif // Old definition, no detection #ifdef SYSV #include #include #if __STDC__ # include #endif #define KSCM_CONFIG_PROMPT "> " #define KSCM_CONFIG_INITFILE "init.scm" #define KSCM_CONFIG_FIRST_CELLSEGS 10 #endif #ifdef KSCM_PLATFORM_VAXC #include #include #define KSCM_CONFIG_PROMPT "> " #define KSCM_CONFIG_INITFILE "init.scm" #define KSCM_CONFIG_FIRST_CELLSEGS 10 #endif #ifdef __GNUC__ /* * If we use gcc, KSCM_CONFIG_AVOID_HACK_LOOP is unnecessary */ #undef KSCM_CONFIG_AVOID_HACK_LOOP #endif #ifndef KSCM_CONFIG_FIRST_CELLSEGS #error Please define your system type. /* * We refrain this to raise an error anyway even if on pre-ANSI system. */ error Please define your system type. #endif /* ========== Evaluation Cycle ========== */ /* operator code */ #define KSCM_OP_LOAD 0 #define KSCM_OP_T0LVL 1 #define KSCM_OP_T1LVL 2 #define KSCM_OP_READ 3 #define KSCM_OP_VALUEPRINT 4 #define KSCM_OP_EVAL 5 #define KSCM_OP_E0ARGS 6 #define KSCM_OP_E1ARGS 7 #define KSCM_OP_APPLY 8 #define KSCM_OP_DOMACRO 9 #define KSCM_OP_LAMBDA 10 #define KSCM_OP_QUOTE 11 #define KSCM_OP_DEF0 12 #define KSCM_OP_DEF1 13 #define KSCM_OP_BEGIN 14 #define KSCM_OP_IF0 15 #define KSCM_OP_IF1 16 #define KSCM_OP_SET0 17 #define KSCM_OP_SET1 18 #define KSCM_OP_LET0 19 #define KSCM_OP_LET1 20 #define KSCM_OP_LET2 21 #define KSCM_OP_LET0AST 22 #define KSCM_OP_LET1AST 23 #define KSCM_OP_LET2AST 24 #define KSCM_OP_LET0REC 25 #define KSCM_OP_LET1REC 26 #define KSCM_OP_LET2REC 27 #define KSCM_OP_COND0 28 #define KSCM_OP_COND1 29 #define KSCM_OP_DELAY 30 #define KSCM_OP_AND0 31 #define KSCM_OP_AND1 32 #define KSCM_OP_OR0 33 #define KSCM_OP_OR1 34 #define KSCM_OP_C0STREAM 35 #define KSCM_OP_C1STREAM 36 #define KSCM_OP_0MACRO 37 #define KSCM_OP_1MACRO 38 #define KSCM_OP_CASE0 39 #define KSCM_OP_CASE1 40 #define KSCM_OP_CASE2 41 #define KSCM_OP_PEVAL 42 #define KSCM_OP_PAPPLY 43 #define KSCM_OP_CONTINUATION 44 #define KSCM_OP_ADD 45 #define KSCM_OP_SUB 46 #define KSCM_OP_MUL 47 #define KSCM_OP_DIV 48 #define KSCM_OP_REM 49 #define KSCM_OP_CAR 50 #define KSCM_OP_CDR 51 #define KSCM_OP_CONS 52 #define KSCM_OP_SETCAR 53 #define KSCM_OP_SETCDR 54 #define KSCM_OP_NOT 55 #define KSCM_OP_BOOL 56 #define KSCM_OP_NULL 57 #define KSCM_OP_ZEROP 58 #define KSCM_OP_POSP 59 #define KSCM_OP_NEGP 60 #define KSCM_OP_NEQ 61 #define KSCM_OP_LESS 62 #define KSCM_OP_GRE 63 #define KSCM_OP_LEQ 64 #define KSCM_OP_GEQ 65 #define KSCM_OP_SYMBOL 66 #define KSCM_OP_NUMBER 67 #define KSCM_OP_STRING 68 #define KSCM_OP_PROC 69 #define KSCM_OP_PAIR 70 #define KSCM_OP_EQ 71 #define KSCM_OP_EQV 72 #define KSCM_OP_FORCE 73 #define KSCM_OP_WRITE 74 #define KSCM_OP_DISPLAY 75 #define KSCM_OP_NEWLINE 76 #define KSCM_OP_ERR0 77 #define KSCM_OP_ERR1 78 #define KSCM_OP_REVERSE 79 #define KSCM_OP_APPEND 80 #define KSCM_OP_PUT 81 #define KSCM_OP_GET 82 #define KSCM_OP_QUIT 83 #define KSCM_OP_GC 84 #define KSCM_OP_GCVERB 85 #define KSCM_OP_NEWSEGMENT 86 #define KSCM_OP_RDSEXPR 87 #define KSCM_OP_RDLIST 88 #define KSCM_OP_RDDOT 89 #define KSCM_OP_RDQUOTE 90 #define KSCM_OP_RDQQUOTE 91 #define KSCM_OP_RDUNQUOTE 92 #define KSCM_OP_RDUQTSP 93 #define KSCM_OP_P0LIST 94 #define KSCM_OP_P1LIST 95 #define KSCM_OP_LIST_LENGTH 96 #define KSCM_OP_ASSQ 97 #define KSCM_OP_PRINT_WIDTH 98 #define KSCM_OP_P0_WIDTH 99 #define KSCM_OP_P1_WIDTH 100 #define KSCM_OP_GET_CLOSURE 101 #define KSCM_OP_CLOSUREP 102 #define KSCM_OP_MACROP 103 #define KSCM_OP_STRCAT 104 #define KSCM_OP_STRLEN 105 #define KSCM_OP_STRGET 106 #define KSCM_OP_SAVE_STATE 107 #define KSCM_OP_RESUME_STATE 108 #define KSCM_OP_BUFFER 109 #define KSCM_OP_BUFFER_NEW 110 #define KSCM_OP_BUFFER_LEN 111 #define KSCM_OP_BUFFER_GET 112 #define KSCM_OP_BUFFER_SET 113 #define KSCM_OP_ABSTRACTION 114 #define KSCM_OP_ABSTRACTION_NEW 115 #define KSCM_OP_ABSTRACTION_TYPE 116 #define KSCM_OP_ABSTRACTION_VALUE 117 #define KSCM_OP_OBJECT 118 #define KSCM_OP_OBJECT_NEW 119 #define KSCM_OP_OBJECT_LEN 120 #define KSCM_OP_OBJECT_GET 121 #define KSCM_OP_OBJECT_SET 122 #define KSCM_OP_OBJECT_RETYPE 123 #define KSCM_OP_SYMBOL_TO_STRING 124 #define KSCM_OP_BUFFER_LOAD 125 #define KSCM_OP_BUFFER_SAVE 126 #define KSCM_OP_CONSOLE_MODE 127 #define KSCM_OP_CONSOLE_NEXT 128 #define KSCM_OP_CONSOLE_POLL 129 #define KSCM_OP_CONSOLE_WIDTH 130 #define KSCM_OP_CONSOLE_HEIGHT 131 #define KSCM_TOK_LPAREN 0 #define KSCM_TOK_RPAREN 1 #define KSCM_TOK_DOT 2 #define KSCM_TOK_ATOM 3 #define KSCM_TOK_QUOTE 4 #define KSCM_TOK_COMMENT 5 #define KSCM_TOK_DQUOTE 6 #ifdef KSCM_CONFIG_USE_QQUOTE # define KSCM_TOK_BQUOTE 7 # define KSCM_TOK_COMMA 8 # define KSCM_TOK_ATMARK 9 #endif #define KSCM_TOK_SHARP 10 typedef struct kscm kscm_t; /* cell structure */ struct kscm_cell { unsigned long _flag; // TODO: This should probably always be 32-bit union { struct { char* _svalue; short _keynum; } _string; struct { long _ivalue; // TODO: This should probably always be 32-bit, i.e. representing a flexible "small int" value } _number; struct { struct kscm_cell* _car; struct kscm_cell* _cdr; } _cons; #ifdef KSCM_CONFIG_USE_STRUCTS struct { unsigned long _length; unsigned char* _data; } _buffer; #endif #ifdef KSCM_CONFIG_USE_FLOATS struct { double _dvalue; } _float64; #endif #ifdef KSCM_CONFIG_USE_OBJECTS struct { struct kscm_cell* _type; long _count; long _gccount; struct kscm_cell** _elements; } _objx; #endif } _object; }; typedef struct kscm_cell* kscm_object_t; typedef struct kscm_gcstate kscm_gcstate_t; struct kscm_gcstate { kscm_object_t object; size_t offset; }; #define KSCM_PERSIST_TINT32 1 #define KSCM_PERSIST_TSTRING 2 #define KSCM_PERSIST_TSYMBOL 3 #define KSCM_PERSIST_TPAIR 4 #define KSCM_PERSIST_TPROC 5 #define KSCM_PERSIST_TCLOSURE 6 #define KSCM_PERSIST_TSYNTAX 7 #define KSCM_PERSIST_TCONTINUATION 8 #define KSCM_PERSIST_TBUFFER 9 #define KSCM_PERSIST_TABSTRACTION 10 #define KSCM_PERSIST_TOBJX 11 #define KSCM_PERSIST_TFLOAT32_RESERVED 12 #define KSCM_PERSIST_TFLOAT64 13 #define KSCM_PERSIST_TUINT64_RESERVED 14 #define KSCM_PERSIST_TINT64_RESERVED 15 #define KSCM_T_STRING 1 /* 0000000000000001 */ #define KSCM_T_NUMBER 2 /* 0000000000000010 */ #define KSCM_T_SYMBOL 4 /* 0000000000000100 */ #define KSCM_T_SYNTAX 8 /* 0000000000001000 */ #define KSCM_T_PROC 16 /* 0000000000010000 */ #define KSCM_T_PAIR 32 /* 0000000000100000 */ #define KSCM_T_CLOSURE 64 /* 0000000001000000 */ #define KSCM_T_CONTINUATION 128 /* 0000000010000000 */ #ifdef KSCM_CONFIG_USE_MACRO # define KSCM_T_MACRO 256/* 0000000100000000 */ #endif #define KSCM_T_PROMISE 512 /* 0000001000000000 */ #define KSCM_T_BUFFER 1024/* 0000010000000000 */ #define KSCM_T_ABSTRACTION 2048/* 0000100000000000 */ #define KSCM_T_OBJX 4096/* 0001000000000000 */ #define KSCM_T_FLOAT64 8192/* 0010000000000000 */ #define KSCM_T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ #define KSCM_CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ #define KSCM_MARK 32768 /* 1000000000000000 */ #define KSCM_UNMARK 32767 /* 0111111111111111 */ /* macros for cell operations */ #define kscm__type(kscm,p) ((p)->_flag) #define kscm__isstring(kscm,p) (kscm__type(kscm, p)&KSCM_T_STRING) #define kscm__strvalue(kscm,p) ((p)->_object._string._svalue) #define kscm__keynum(kscm,p) ((p)->_object._string._keynum) #define kscm__isnumber(kscm,p) (kscm__type(kscm, p)&KSCM_T_NUMBER) #define kscm__ivalue(kscm,p) ((p)->_object._number._ivalue) #ifdef KSCM_CONFIG_USE_FLOATS #define kscm__isfloat64(kscm,p) (kscm__type(kscm, p)&KSCM_T_FLOAT64) #define kscm__dvalue(kscm,p) ((p)->_object._float64._dvalue) #endif #define kscm__ispair(kscm,p) (kscm__type(kscm,p)&KSCM_T_PAIR) #define kscm__car(kscm,p) (p)->_object._cons._car #define kscm__cdr(kscm,p) (p)->_object._cons._cdr #define kscm__issymbol(kscm,p) (kscm__type(kscm, p)&KSCM_T_SYMBOL) #define kscm__symname(kscm,p) kscm__strvalue(kscm, kscm__car(kscm, p)) #define kscm__hasprop(kscm,p) (kscm__type(kscm, p)&KSCM_T_SYMBOL) #define kscm__symprop(kscm,p) kscm__cdr(kscm, p) #define kscm__issyntax(kscm,p) (kscm__type(kscm, p)&KSCM_T_SYNTAX) #define kscm__isproc(kscm,p) (kscm__type(kscm, p)&KSCM_T_PROC) #define kscm__syntaxname(kscm,p) kscm__strvalue(kscm, kscm__car(kscm, p)) #define kscm__syntaxnum(kscm,p) kscm__keynum(kscm, kscm__car(kscm, p)) #define kscm__procnum(kscm,p) kscm__ivalue(kscm, p) #define kscm__isclosure(kscm,p) (kscm__type(kscm, p)&KSCM_T_CLOSURE) #ifdef KSCM_CONFIG_USE_MACRO # define kscm__ismacro(kscm,p) (kscm__type(kscm, p)&KSCM_T_MACRO) #endif #define kscm__closure_code(kscm,p) kscm__car(kscm, p) #define kscm__closure_env(kscm,p) kscm__cdr(kscm, p) #define kscm__iscontinuation(kscm,p) (kscm__type(kscm, p)&KSCM_T_CONTINUATION) #define kscm__cont_dump(kscm,p) kscm__cdr(kscm, p) #define kscm__ispromise(kscm,p) (kscm__type(kscm,p)&KSCM_T_PROMISE) #define kscm__setpromise(kscm,p) kscm__type(kscm,p) |= KSCM_T_PROMISE #ifdef KSCM_CONFIG_USE_STRUCTS #define kscm__isbuffer(kscm,p) (kscm__type(kscm,p)&KSCM_T_BUFFER) #define kscm__isabstraction(kscm,p) (kscm__type(kscm,p)&KSCM_T_ABSTRACTION) #endif #ifdef KSCM_CONFIG_USE_OBJECTS #define kscm__isobjx(kscm,p) (kscm__type(kscm,p)&KSCM_T_OBJX) #endif #define kscm__isatom(kscm,p) (kscm__type(kscm,p)&KSCM_T_ATOM) #define kscm__setatom(kscm,p) kscm__type(kscm,p) |= KSCM_T_ATOM #define kscm__clratom(kscm,p) kscm__type(kscm,p) &= KSCM_CLRATOM #define kscm__ismark(kscm,p) (kscm__type(kscm, p)&KSCM_MARK) #define kscm__setmark(kscm,p) kscm__type(kscm, p) |= KSCM_MARK #define kscm__clrmark(kscm,p) kscm__type(kscm, p) &= KSCM_UNMARK #define kscm__caar(kscm, p) kscm__car(kscm, kscm__car(kscm, p)) #define kscm__cadr(kscm, p) kscm__car(kscm, kscm__cdr(kscm, p)) #define kscm__cdar(kscm, p) kscm__cdr(kscm, kscm__car(kscm, p)) #define kscm__cddr(kscm, p) kscm__cdr(kscm, kscm__cdr(kscm, p)) #define kscm__cadar(kscm, p) kscm__car(kscm, kscm__cdr(kscm, kscm__car(kscm, p))) #define kscm__caddr(kscm, p) kscm__car(kscm, kscm__cdr(kscm, kscm__cdr(kscm, p))) #define kscm__cadaar(kscm, p) kscm__car(kscm, kscm__cdr(kscm, kscm__car(kscm, kscm__car(kscm, p)))) #define kscm__cadddr(kscm, p) kscm__car(kscm, kscm__cdr(kscm, kscm__cdr(kscm, kscm__cdr(kscm, p)))) #define kscm__cddddr(kscm, p) kscm__cdr(kscm, kscm__cdr(kscm, kscm__cdr(kscm, kscm__cdr(kscm, p)))) #define LINESIZE 1024 struct kscm { /* arrays for segments */ kscm_object_t* cell_seg; int last_cell_seg;// = -1; int gcstate_max; kscm_gcstate_t* gcstate; //char* str_seg[KSCM_CONFIG_STR_NSEGMENT]; //int str_seglast;// = -1; /* We use 4 registers (actually, some more registers are used internally). */ kscm_object_t args; /* register for arguments of function */ kscm_object_t envir; /* stack register for current environment */ kscm_object_t code; /* register for current code */ kscm_object_t dump; /* stack register for next evaluation */ /* The VM is currently single-threaded, but to facilitate compatibility with future/other versions * some information is associated with the "main thread" as though it were one thread in a multi-threaded * environment. */ int _threadstate; kscm_object_t _threadname; kscm_object_t _threadopts; kscm_object_t _threadobject; /* Right now, the state format just contains the number of bytes per reference (either 4 or 8). */ int _stateformat; //struct kscm_cell _NIL; kscm_object_t NIL;// = &_NIL; /* special cell representing empty cell */ //struct kscm_cell _T; kscm_object_t T;// = &_T; /* special cell representing #t */ //struct kscm_cell _F; kscm_object_t F;// = &_F; /* special cell representing #f */ kscm_object_t oblist;// = &_NIL; /* pointer to symbol table */ kscm_object_t global_env; /* pointer to global environment */ /* global pointers to special symbols */ kscm_object_t LAMBDA; /* pointer to syntax lambda */ kscm_object_t QUOTE; /* pointer to syntax quote */ #ifdef KSCM_CONFIG_USE_QQUOTE kscm_object_t QQUOTE; /* pointer to symbol quasiquote */ kscm_object_t UNQUOTE; /* pointer to symbol unquote */ kscm_object_t UNQUOTESP; /* pointer to symbol unquote-splicing */ #endif kscm_object_t free_cell;// = &_NIL; /* pointer to top of free cells */ long fcells;// = 0; /* # of free cells */ //FILE* infp; /* input file */ FILE* inputs[KSCM_CONFIG_MAXLOADS]; int inputtop; // = 0; (TODO: Remove the other initialisers - assume calloc or similar clears memory prior during manual initialisation) FILE* outfp; /* output file */ #ifdef KSCM_CONFIG_USE_SETJMP jmp_buf error_jmp; #endif char gc_verbose; /* if gc_verbose is not zero, print gc status */ int quiet;// = 0; /* if not zero, print KSCM_CONFIG_BANNER, KSCM_CONFIG_PROMPT, results */ int all_errors_fatal;// = 0; /* if not zero, every error is a FatalError */ FILE* tmpfp; int tok; int print_flag; kscm_object_t value; short _operator; char linebuff[LINESIZE]; char strbuff[256]; char* currentline;// = linebuff; char* endline;// = linebuff; }; /* allocate new cell segment */ int kscm__alloc_cellseg(kscm_t *kscm, int n) { /*register*/ kscm_object_t p; /*register*/ long i; /*register*/ int k; for (k = 0; k < n; k++) { if (kscm->last_cell_seg >= (KSCM_CONFIG_CELL_NSEGMENT - 1)) return k; p = (kscm_object_t)calloc(1,KSCM_CONFIG_CELL_SEGSIZE * sizeof(struct kscm_cell)); if (p == (kscm_object_t)0) return k; kscm->last_cell_seg++; kscm->cell_seg[kscm->last_cell_seg] = p; kscm->fcells += KSCM_CONFIG_CELL_SEGSIZE; for (i = 0; i < KSCM_CONFIG_CELL_SEGSIZE; i++) { kscm__type(kscm, p+i) = 0; kscm__car(kscm, p+i) = kscm->NIL; kscm__cdr(kscm, p+i) = kscm->free_cell; kscm->free_cell = p+i; //p++; } //for (i = 0; i < (KSCM_CONFIG_CELL_SEGSIZE - 1); i++/*, p++*/) { /* kscm__type(kscm, p) = 0; kscm__car(kscm, p) = kscm->NIL; kscm__cdr(kscm, p) = (p + 1); //fprintf(stderr, "Added cell %d @ %lx %lx %lx\n", i, kscm__cdr(kscm, p), (p + 1), kscm->NIL); p++; } kscm__type(kscm, p) = 0; kscm__car(kscm, p) = kscm->NIL; kscm__cdr(kscm, p) = kscm->free_cell; kscm->free_cell = kscm->cell_seg[kscm->last_cell_seg];*/ } return n; } /* allocate new string segment */ /*int kscm__alloc_strseg(kscm_t* kscm, int n) { register char* p; register long i; register int k; for (k = 0; k < n; k++) { if (kscm->str_seglast >= KSCM_CONFIG_STR_NSEGMENT) return k; p = (char*)malloc(KSCM_CONFIG_STR_SEGSIZE * sizeof(char)); if (p == (char*)0) return k; kscm->str_seg[++kscm->str_seglast] = p; for (i = 0; i < KSCM_CONFIG_STR_SEGSIZE; i++) *p++ = (char)(-1); } return n; }*/ void kscm__fatal_error(kscm_t* kscm, const char* msg, const char* a, const char* b, const char* c); void kscm__error(kscm_t* kscm, const char* msg, const char* a, const char* b, const char* c); void kscm__init_globals(kscm_t* kscm); kscm_object_t kscm__mk_string(kscm_t* kscm, const char* str); struct kscm_cell _NIL; struct kscm_cell _T; struct kscm_cell _F; /* initialization of Mini-Scheme */ void kscm__init_scheme(kscm_t* kscm) { memset(&_NIL, 0, sizeof(struct kscm_cell)); memset(&_T, 0, sizeof(struct kscm_cell)); memset(&_F, 0, sizeof(struct kscm_cell)); /*register*/ kscm_object_t i; kscm->last_cell_seg = -1; //kscm->str_seglast = -1; kscm->NIL = &_NIL; kscm->T = &_T; kscm->F = &_F; kscm->oblist = &_NIL; kscm->free_cell = &_NIL; fprintf(stderr, "Initialising scheme...\n"); if (kscm__alloc_cellseg(kscm, KSCM_CONFIG_FIRST_CELLSEGS) != KSCM_CONFIG_FIRST_CELLSEGS) kscm__fatal_error(kscm, "Unable to allocate initial cell segments", NULL, NULL, NULL); /*if (!kscm__alloc_strseg(kscm, 1)) kscm__fatal_error(kscm, "Unable to allocate initial string segments", NULL, NULL, NULL);*/ #ifdef VERBOSE kscm->gc_verbose = 1; #else kscm->gc_verbose = 0; #endif kscm->_stateformat = 4; kscm->_threadstate = 1; kscm->_threadobject = kscm->NIL; fprintf(stderr, "Initialising strings...\n"); kscm->_threadname = kscm__mk_string(kscm, "main"); fprintf(stderr, "Initialising strings...\n"); kscm->_threadopts = kscm__mk_string(kscm, ""); fprintf(stderr, "Initialising globals...\n"); kscm__init_globals(kscm); } void kscm__gc(kscm_t* kscm,/* register*/ kscm_object_t a, /*register*/ kscm_object_t b); /* get new cell. parameter a, b is marked by gc. */ kscm_object_t kscm__get_cell(kscm_t* kscm, /*register*/ kscm_object_t a, /*register*/ kscm_object_t b) { // return calloc(1,sizeof(struct kscm_cell)); //#if 0 /*register*/ kscm_object_t x; //fprintf(stderr, "A\n"); if (kscm->free_cell == kscm->NIL) { //fprintf(stderr, "B\n"); kscm__gc(kscm, a, b); if (kscm->free_cell == kscm->NIL) { //fprintf(stderr, "C\n"); #ifdef KSCM_CONFIG_USE_SETJMP if (!kscm__alloc_cellseg(kscm, 1)) { //fprintf(stderr, "D\n"); kscm->args = kscm->envir = kscm->code = kscm->dump = kscm->NIL; kscm__gc(kscm, kscm->NIL, kscm->NIL); if (kscm->free_cell != kscm->NIL) { kscm__error(kscm, "run out of cells --- rerurn to top level", NULL, NULL, NULL); } else { kscm__fatal_error(kscm, "run out of cells --- unable to recover cells", NULL, NULL, NULL); } } #else if (!kscm__alloc_cellseg(kscm, 1)) { //fprintf(stderr, "E\n"); kscm__fatal_error(kscm, "run out of cells --- unable to recover cells", NULL, NULL, NULL); } #endif } } //fprintf(stderr, "F\n"); x = kscm->free_cell; //fprintf(stderr, "G %lx\n", x); //fprintf(stderr, "G %lx\n", kscm__cdr(kscm, x)); kscm->free_cell = kscm__cdr(kscm, x); //fprintf(stderr, "H\n"); kscm->fcells--; //fprintf(stderr, "I\n"); return x; //#endif } /* get new cons cell */ kscm_object_t kscm__cons(kscm_t* kscm, register kscm_object_t a, register kscm_object_t b) { register kscm_object_t x = kscm__get_cell(kscm, a, b); kscm__type(kscm, x) = KSCM_T_PAIR; kscm__car(kscm, x) = a; kscm__cdr(kscm, x) = b; return (x); } /* get number atom */ kscm_object_t kscm__mk_number(kscm_t* kscm, register long num) { register kscm_object_t x = kscm__get_cell(kscm, kscm->NIL, kscm->NIL); kscm__type(kscm, x) = (KSCM_T_NUMBER | KSCM_T_ATOM); kscm__ivalue(kscm, x) = num; return (x); } #ifdef KSCM_CONFIG_USE_FLOATS kscm_object_t kscm__mk_float64(kscm_t* kscm, double value) { kscm_object_t x = kscm__get_cell(kscm, kscm->NIL, kscm->NIL); kscm__type(kscm, x) = (KSCM_T_FLOAT64 | KSCM_T_ATOM); x->_object._float64._dvalue = value; return x; } #endif /* allocate name to string area */ //char* kscm__store_string(kscm_t* kscm, const char *name) //{ // register char* q = NULL; // register short i; // long len, remain; // // /* first check name has already listed */ // for (i = 0; i <= kscm->str_seglast; i++) // for (q = kscm->str_seg[i]; *q != (char)(-1); ) { // if (!strcmp(q, name)) // goto FOUND; // while (*q++) // ; /* get next string */ // } // len = strlen(name) + 2; // // TODO: Replace legacy types, it's starting to get ugly. -Zak // remain = (long long)KSCM_CONFIG_STR_SEGSIZE - ((long long)q - (long long)kscm->str_seg[kscm->str_seglast]); // if (remain < len) { // if (!kscm__alloc_strseg(kscm, 1)) // kscm__fatal_error(kscm, "run out of string area", NULL, NULL, NULL); // q = kscm->str_seg[kscm->str_seglast]; // /*if ((long long)KSCM_CONFIG_STR_SEGSIZE - ((long long)q - (long long)kscm->str_seg[kscm->str_seglast])) { // fprintf(stderr, "String in question's total length is %d", len); // kscm__fatal_error(kscm, "string too big", NULL, NULL, NULL); // }*/ // } // strcpy(q, name); //FOUND: // return (q); //} /* get new string */ kscm_object_t kscm__mk_string(kscm_t* kscm, const char *str) { /*register*/ kscm_object_t x = kscm__get_cell(kscm, kscm->NIL, kscm->NIL); #ifdef __WIN32 kscm__strvalue(kscm, x) = _strdup(str);//kscm__store_string(kscm, str); #else kscm__strvalue(kscm, x) = strdup(str);//kscm__store_string(kscm, str); #endif kscm__type(kscm, x) = (KSCM_T_STRING | KSCM_T_ATOM); kscm__keynum(kscm, x) = (short)(-1); return (x); } /* get new symbol */ kscm_object_t kscm__mk_symbol(kscm_t* kscm, const char *name) { register kscm_object_t x; /* fisrt check oblist */ for (x = kscm->oblist; x != kscm->NIL; x = kscm__cdr(kscm, x)) if (!strcmp(name, kscm__symname(kscm, kscm__car(kscm, x)))) break; if (x != kscm->NIL) return (kscm__car(kscm, x)); else { x = kscm__cons(kscm, kscm__mk_string(kscm, name), kscm->NIL); kscm__type(kscm, x) = KSCM_T_SYMBOL; kscm->oblist = kscm__cons(kscm, x, kscm->oblist); return (x); } } #ifdef KSCM_CONFIG_USE_STRUCTS kscm_object_t kscm__mk_buffer(kscm_t* kscm, long len) { void* d = calloc(1, len); if (d == NULL) { return kscm->NIL; } kscm_object_t result = kscm__get_cell(kscm, kscm->NIL, kscm->NIL); kscm__type(kscm, result) = (KSCM_T_BUFFER | KSCM_T_ATOM); result->_object._buffer._length = len; result->_object._buffer._data = (unsigned char*) d; return result; } kscm_object_t kscm__mk_abstraction(kscm_t* kscm, register kscm_object_t a, register kscm_object_t b) { register kscm_object_t x = kscm__get_cell(kscm, a, b); kscm__type(kscm, x) = KSCM_T_ABSTRACTION; kscm__car(kscm, x) = a; kscm__cdr(kscm, x) = b; return (x); } #endif #ifdef KSCM_CONFIG_USE_OBJECTS kscm_object_t kscm__mk_objx(kscm_t* kscm, kscm_object_t typ, long len) { void* d = calloc(sizeof(kscm_object_t), len); if (d == NULL) { return kscm->NIL; } kscm_object_t result = kscm__get_cell(kscm, typ, kscm->NIL); kscm__type(kscm, result) = KSCM_T_OBJX; result->_object._objx._type = typ; result->_object._objx._count = len; result->_object._objx._elements = (kscm_object_t*)d; long i; for (i = 0; i < len; i++) { result->_object._objx._elements[i] = kscm->NIL; } return result; } #endif #ifdef KSCM_CONFIG_USE_PRECISE int kscm__safedigit(kscm_t* kscm, int base, char d) { if (base <= 10) { if (d >= '0' && d < '0' + base) { return d - '0'; } else { return -1; } } else if (base == 16) { if (d >= '0' && d < '0' + 10) { return d - '0'; } else if (d >= 'a' && d < 'a' + 6) { return 10 + (d - 'a'); } else if (d >= 'A' && d < 'A' + 6) { return 10 + (d - 'A'); } else { return -1; } } else { return -1; } } kscm_object_t kscm__mk_safenum(kscm_t* kscm, int base, const char* src) { char c; const char* p; int32_t v = 0; int negate = 0; p = src; if (p[0] == '-') { negate = 1; p++; } else if (p[0] == '+') { p++; } if (kscm__safedigit(kscm, base, p[0]) < 0) { return kscm->F; } while (kscm__safedigit(kscm, base, p[0]) >= 0) { int64_t lv = ((int64_t)v) * base + kscm__safedigit(kscm, base, p[0]); v = (int32_t)lv; //printf("Adding digit %d to get %d\n", kscm__safedigit(kscm, base, p[0]), v); if (((int64_t)v) != lv) { return kscm->F; } p++; } if (negate) { v = -v; } return kscm__mk_number(kscm, v); } #endif /* make symbol or number atom from string */ kscm_object_t kscm__mk_atom(kscm_t* kscm, const char *q) { char c; const char *p; p = q; if (!isdigit(c = *p++)) { if ((c != '+' && c != '-') || !isdigit(*p)) return (kscm__mk_symbol(kscm, q)); } #ifdef KSCM_CONFIG_USE_FLOATS bool isFloat = false; bool hasE = false; bool hasESign = false; char prev = ' '; for (; (c = *p) != 0; ++p) { if (!isdigit(c)) { if (!isFloat && c == '.') { isFloat = true; } else if (isFloat && !hasE && (c == 'e' || c == 'E')) { hasE = true; } else if (isFloat && hasE && (prev == 'e' || prev == 'E') && (c == '+' || c == '-')) { hasESign = true; } else { return (kscm__mk_symbol(kscm, q)); } } prev = c; } if (isFloat) { return kscm__mk_float64(kscm, atof(q)); } #else for (; (c = *p) != 0; ++p) if (!isdigit(c)) return (kscm__mk_symbol(kscm, q)); #endif #ifdef KSCM_CONFIG_USE_PRECISE kscm_object_t result = kscm__mk_safenum(kscm, 10, q); if (result == kscm->F) { //fprintf(stderr, "WARNING: Math overflow in '%s'\n", q); result = kscm__cons(kscm, kscm__mk_symbol(kscm, "parse-number"), kscm__cons(kscm, kscm__mk_string(kscm, q), kscm->NIL)); } return result; #else return (kscm__mk_number(kscm, atol(q))); #endif } /* make constant */ kscm_object_t kscm__mk_const(kscm_t* kscm, const char *name) { long x; char tmp[256]; if (!strcmp(name, "t")) return (kscm->T); else if (!strcmp(name, "f")) return (kscm->F); else if (*name == 'o') {/* #o (octal) */ sprintf(tmp, "0%s", /*&name[1]*/ name+1); fprintf(stderr, "TODO: Octal parsing!\n"); exit(-1); //sscanf(tmp, "%lo", (unsigned long int*) & x); return (kscm__mk_number(kscm, x)); } else if (*name == 'd') { /* #d (decimal) */ x = atoll(name+1); //sscanf(&name[1], "%ld", &x); return (kscm__mk_number(kscm, x)); } else if (*name == 'x') { /* #x (hex) */ sprintf(tmp, "0x%s", &name[1]); fprintf(stderr, "TODO: Hex parsing!\n"); exit(-1); //sscanf(tmp, "%lx", (unsigned long int*) & x); return (kscm__mk_number(kscm, x)); } else return (kscm->NIL); } /* ========== garbage collector ========== */ /*-- * We use algorithm E (Kunuth, The Art of Computer Programming Vol.1, * sec.3.5) for marking. * * NOTE: The implementation is complicated a bit when using object-oriented/vector extensions. * I've decided to just use recursive marking in this case, but I've added some documentation to * the original algorithm as well in case anyone wants to update it. */ #ifdef KSCM_CONFIG_USE_OBJECTS #define KSCM_GC_MAXREC 100000 void kscm__fastmark(kscm_t* kscm, kscm_object_t root) { int stacklevel = 0; kscm->gcstate[stacklevel].object = root; kscm->gcstate[stacklevel].offset = 0; while (stacklevel >= 0) { kscm_object_t a = kscm->gcstate[stacklevel].object; long o = kscm->gcstate[stacklevel].offset; if (o == 0) { if (kscm__ismark(kscm, a)) { stacklevel--; continue; } kscm__setmark(kscm, a); if (kscm__isatom(kscm, a)) { stacklevel--; continue; } } kscm->gcstate[stacklevel].offset = o + 1; if (stacklevel + 1 >= kscm->gcstate_max) { fprintf(stderr, "ERROR: Garbage collection stack limit reached! Current limit is set at %d!\n", kscm->gcstate_max); exit(-1); } if (kscm__isobjx(kscm, a)) { if (o == 0) { stacklevel++; kscm->gcstate[stacklevel].object = a->_object._objx._type; kscm->gcstate[stacklevel].offset = 0; } else if (o - 1 >= a->_object._objx._count) { stacklevel--; continue; } else { stacklevel++; kscm->gcstate[stacklevel].object = a->_object._objx._elements[o-1]; kscm->gcstate[stacklevel].offset = 0; } } else { /* Is pair or pair-like abstraction*/ if (o == 0) { stacklevel++; kscm->gcstate[stacklevel].object = kscm__car(kscm, a); kscm->gcstate[stacklevel].offset = 0; } else if (o == 1) { stacklevel++; kscm->gcstate[stacklevel].object = kscm__cdr(kscm, a); kscm->gcstate[stacklevel].offset = 0; } else { stacklevel--; continue; } } } } void kscm__recursivemark(kscm_t* kscm, kscm_object_t a, int recursionlevel) { printf("Recursion=%d\n", recursionlevel); if (recursionlevel > KSCM_GC_MAXREC) { fprintf(stderr, "WARNING: Garbage collector is recursing like a motherfucker\n"); recursionlevel = 0; // We just reset it though, the warning should be enough to show if it's becoming a problem } if (kscm__ismark(kscm, a)) { return; } kscm__setmark(kscm, a); if (kscm__isatom(kscm, a)) { return; } if (kscm__isobjx(kscm, a)) { kscm__recursivemark(kscm, a->_object._objx._type, recursionlevel + 1); int i; for (i = 0; i < a->_object._objx._count; i++) { //printf("Recursively marking object at index %d\n", i); kscm__recursivemark(kscm, a->_object._objx._elements[i], recursionlevel + 1); } } else { /* Is pair or pair-like abstraction*/ kscm__recursivemark(kscm, kscm__car(kscm, a), recursionlevel + 1); kscm__recursivemark(kscm, kscm__cdr(kscm, a), recursionlevel + 1); } } void kscm__mark(kscm_t* kscm, kscm_object_t a) { //kscm__recursivemark(kscm, a, 1); kscm__fastmark(kscm, a); } #else void kscm__mark(kscm_t* kscm, kscm_object_t a) { register kscm_object_t t; /* Used to track the previous object. This object will in turn be used to track it's previous. */ register kscm_object_t q; /* Used as a temporary value to hold our subreferences. */ register kscm_object_t p; /* Points to the current object. */ /* E1: Start of algorithm. Reset t and p. */ E1: t = (kscm_object_t)0; p = a; /* E2: Start by marking p (i.e. marking it as "keep this cell"). */ E2: kscm__setmark(kscm, p); /* E3: Check type. If it's an atom (not built out of references to other cells) we can skip marking references. */ E3: if (kscm__isatom(kscm, p)) goto E6; /* E4: Mark first reference ("car" or equivalent) if it's not already marked. */ E4: q = kscm__car(kscm, p); if (q && !kscm__ismark(kscm, q)) { kscm__setatom(kscm, p); kscm__car(kscm, p) = t; t = p; p = q; goto E2; } /* E5: Mark second/nth references if they're not already marked. */ E5: q = kscm__cdr(kscm, p); if (q && !kscm__ismark(kscm, q)) { kscm__cdr(kscm, p) = t; t = p; p = q; goto E2; } /* E6: This object is now fully marked. If there's no previous object, we can just return. Otherwise, * we reload the previous object (and set the new previous to the one stored in "car" or equivalent), * and continue marking it's subreferences. */ E6: if (!t) return; q = t; if (kscm__isatom(kscm, q)) { kscm__clratom(kscm, q); t = kscm__car(kscm, q); kscm__car(kscm, q) = p; p = q; goto E5; } else { t = kscm__cdr(kscm, q); kscm__cdr(kscm, q) = p; p = q; goto E6; } } #endif /* garbage collection. parameter a, b is marked. */ void kscm__gc(kscm_t* kscm, /*register*/ kscm_object_t a, /*register*/ kscm_object_t b) { /*register*/ kscm_object_t p; /*register*/ short i; /*register*/ long j; if (kscm->gc_verbose) printf("gc..."); /* mark system globals */ kscm__mark(kscm, kscm->oblist); kscm__mark(kscm, kscm->global_env); /* mark current registers */ kscm__mark(kscm, kscm->args); kscm__mark(kscm, kscm->envir); kscm__mark(kscm, kscm->code); kscm__mark(kscm, kscm->dump); /* mark thread values (this implementation is single-threaded but we keep them anyway) */ kscm__mark(kscm, kscm->_threadname); kscm__mark(kscm, kscm->_threadopts); kscm__mark(kscm, kscm->_threadobject); /* mark variables a, b */ kscm__mark(kscm, a); kscm__mark(kscm, b); /* garbage collect */ kscm__clrmark(kscm, kscm->NIL); kscm->fcells = 0; kscm->free_cell = kscm->NIL; for (i = 0; i <= kscm->last_cell_seg; i++) { j = 0; for (/*j = 0,*/ p = kscm->cell_seg[i]; j < KSCM_CONFIG_CELL_SEGSIZE; j++/*, p++*/) { if (kscm__ismark(kscm, p)) kscm__clrmark(kscm, p); else { if (kscm__isstring(kscm, p)) { if (p->_object._string._svalue != NULL) { free(p->_object._string._svalue); } } #ifdef KSCM_CONFIG_USE_STRUCTS if (kscm__isbuffer(kscm, p)) { if (p->_object._buffer._data != NULL) { //fprintf(stderr, "Freeing a buffer of %d length\n", p->_object._buffer._length); free(p->_object._buffer._data); p->_object._buffer._data = NULL; } } #endif #ifdef KSCM_CONFIG_USE_OBJECTS if (kscm__isobjx(kscm, p)) { if (p->_object._objx._elements != NULL) { free(p->_object._objx._elements); p->_object._objx._elements = NULL; } } #endif // TODO: Should probably clear the whole structure before setting defaults or adding to free list // (this could help avoid bugs if larger-than-pair structures aren't cleared or reset properly elsewhere) kscm__type(kscm, p) = 0; kscm__cdr(kscm, p) = kscm->free_cell; kscm__car(kscm, p) = kscm->NIL; kscm->free_cell = p; kscm->fcells++; } p = p + 1; } } if (kscm->gc_verbose) printf(" done %ld cells are recovered.\n", kscm->fcells); } /* ========== Rootines for Reading ========== */ /* get new character from input file */ int kscm__inchar(kscm_t* kscm) { if (kscm->currentline >= kscm->endline) { /* input buffer is empty */ if (feof(kscm->inputs[kscm->inputtop])) { fclose(kscm->inputs[kscm->inputtop]); if (kscm->inputtop > 0) { // return to outer input kscm->inputs[kscm->inputtop] = NULL; kscm->inputtop--; if (kscm->inputs[kscm->inputtop] == stdin) { if (!kscm->quiet) {printf(KSCM_CONFIG_PROMPT);fflush(stdout);} } } else { // go back to the top-level kscm->inputs[kscm->inputtop] = stdin; if (!kscm->quiet) {printf(KSCM_CONFIG_PROMPT);fflush(stdout);} } } strcpy(kscm->linebuff, "\n"); // TODO: Why's this here? -Zak. if (fgets(kscm->currentline = kscm->linebuff, LINESIZE, kscm->inputs[kscm->inputtop]) == NULL) if (kscm->inputs[kscm->inputtop] == stdin) { if (!kscm->quiet) fprintf(stderr, "Good-bye\n"); exit(0); } kscm->endline = kscm->linebuff + strlen(kscm->linebuff); } return (*kscm->currentline++); } /* clear input buffer */ void kscm__clearinput(kscm_t* kscm) { kscm->currentline = kscm->endline = kscm->linebuff; } /* back to standard input */ void kscm__resetinput(kscm_t* kscm) { /*if (kscm->inputs[kscm->inputtop] != stdin) { fclose(kscm->inputs[kscm->inputtop]); kscm->inputs[kscm->inputtop] = stdin; }*/ while (kscm->inputtop > 0 || kscm->inputs[kscm->inputtop] != stdin) { fclose(kscm->inputs[kscm->inputtop]); if (kscm->inputtop > 0) { // return to outer input kscm->inputs[kscm->inputtop] = NULL; kscm->inputtop--; } else { // go back to the top-level kscm->inputs[kscm->inputtop] = stdin; if (!kscm->quiet) {printf(KSCM_CONFIG_PROMPT);fflush(stdout);} } } kscm__clearinput(kscm); } /* back character to input buffer */ void kscm__backchar(kscm_t* kscm) { kscm->currentline--; } int kscm__isdelim(kscm_t* kscm, const char* s, char c); /* read chacters to delimiter */ char* kscm__readstr(kscm_t* kscm, const char *delim) { char* p = kscm->strbuff; while (kscm__isdelim(kscm, delim, (*p++ = kscm__inchar(kscm)))) ; kscm__backchar(kscm); *--p = '\0'; return (kscm->strbuff); } /* read string expression "xxx...xxx" */ char* kscm__readstrexp(kscm_t* kscm) { char c, * p = kscm->strbuff; for (;;) { if ((c = kscm__inchar(kscm)) != '"') *p++ = c; else if (p > kscm->strbuff&&* (p - 1) == '\\') *(p - 1) = '"'; else { *p = '\0'; return (kscm->strbuff); } } } /* check c is delimiter */ int kscm__isdelim(kscm_t* kscm, const char *s, char c) { while (*s) if (*s++ == c) return (0); return (1); } /* skip white characters */ void kscm__skipspace(kscm_t* kscm) { while (isspace(kscm__inchar(kscm))) ; kscm__backchar(kscm); } /* get token */ int kscm__token(kscm_t* kscm) { kscm__skipspace(kscm); switch (kscm__inchar(kscm)) { case '(': return (KSCM_TOK_LPAREN); case ')': return (KSCM_TOK_RPAREN); case '.': return (KSCM_TOK_DOT); case '\'': return (KSCM_TOK_QUOTE); case ';': return (KSCM_TOK_COMMENT); case '"': return (KSCM_TOK_DQUOTE); #ifdef KSCM_CONFIG_USE_QQUOTE case BACKQUOTE: return (KSCM_TOK_BQUOTE); case ',': if (kscm__inchar(kscm) == '@') return (KSCM_TOK_ATMARK); else { kscm__backchar(kscm); return (KSCM_TOK_COMMA); } #endif case '#': return (KSCM_TOK_SHARP); default: kscm__backchar(kscm); return (KSCM_TOK_ATOM); } } /* ========== Rootines for Printing ========== */ #define kscm__ok_abbrev(kscm,x) (kscm__ispair(kscm, x) && kscm__cdr(kscm, x) == kscm->NIL) void kscm__strunquote(kscm_t* kscm, char *p, const char *s) { *p++ = '"'; for (; *s; ++s) { if (*s == '"') { *p++ = '\\'; *p++ = '"'; } else if (*s == '\n') { *p++ = '\\'; *p++ = 'n'; } else *p++ = *s; } *p++ = '"'; *p = '\0'; } /* print atoms */ int kscm__printatom(kscm_t* kscm, kscm_object_t l, int f) { char *p = NULL; if (l == kscm->NIL) p = (char*)(void*)"()"; else if (l == kscm->T) p = (char*)(void*)"#t"; else if (l == kscm->F) p = (char*)(void*)"#f"; else if (kscm__isnumber(kscm, l)) { p = kscm->strbuff; sprintf(p, "%ld", kscm__ivalue(kscm, l)); } else if (kscm__isfloat64(kscm, l)) { p = kscm->strbuff; sprintf(p, "%f", l->_object._float64._dvalue); } else if (kscm__isstring(kscm, l)) { if (!f) p = kscm__strvalue(kscm, l); else { p = kscm->strbuff; kscm__strunquote(kscm, p, kscm__strvalue(kscm, l)); } } else if (kscm__issymbol(kscm, l)) p = kscm__symname(kscm, l); else if (kscm__isproc(kscm, l)) { p = kscm->strbuff; sprintf(p, "#", kscm__procnum(kscm, l)); #ifdef KSCM_CONFIG_USE_MACRO } else if (kscm__ismacro(kscm, l)) { p = (char*)(void*)"#"; #endif #ifdef KSCM_CONFIG_USE_STRUCTS } else if (kscm__isbuffer(kscm, l)) { p = (char*)(void*)"#"; } else if (kscm__isabstraction(kscm, l)) { p = (char*)(void*)"#"; #endif #ifdef KSCM_CONFIG_USE_OBJECTS } else if (kscm__isobjx(kscm, l)) { p = (char*)(void*)"#"; #endif } else if (kscm__isclosure(kscm, l)) p = (char*)(void*)"#"; else if (kscm__iscontinuation(kscm, l)) p = (char*)(void*)"#"; if (f < 0) return strlen(p); fputs(p, kscm->outfp); return 0; } /* ========== Rootines for Evaluation Cycle ========== */ /* make closure. c is code. e is environment */ kscm_object_t kscm__mk_closure(kscm_t* kscm, register kscm_object_t c, register kscm_object_t e) { register kscm_object_t x = kscm__get_cell(kscm, c, e); kscm__type(kscm, x) = KSCM_T_CLOSURE; kscm__car(kscm, x) = c; kscm__cdr(kscm, x) = e; return (x); } /* make continuation. */ kscm_object_t kscm__mk_continuation(kscm_t* kscm, register kscm_object_t d) { register kscm_object_t x = kscm__get_cell(kscm, kscm->NIL, d); kscm__type(kscm, x) = KSCM_T_CONTINUATION; kscm__cont_dump(kscm, x) = d; return (x); } /* reverse list -- make new cells */ kscm_object_t kscm__reverse(kscm_t* kscm, register kscm_object_t a) /* a must be checked by gc */ { register kscm_object_t p = kscm->NIL; for (; kscm__ispair(kscm, a); a = kscm__cdr(kscm, a)) p = kscm__cons(kscm, kscm__car(kscm, a), p); return (p); } /* reverse list --- no make new cells */ kscm_object_t kscm__non_alloc_rev(kscm_t* kscm, kscm_object_t term, kscm_object_t list) { register kscm_object_t p = list, result = term, q; while (p != kscm->NIL) { q = kscm__cdr(kscm, p); kscm__cdr(kscm, p) = result; result = p; p = q; } return (result); } /* append list -- make new cells */ kscm_object_t kscm__append(kscm_t* kscm, register kscm_object_t a, register kscm_object_t b) { register kscm_object_t p = b, q; if (a != kscm->NIL) { a = kscm__reverse(kscm, a); while (a != kscm->NIL) { q = kscm__cdr(kscm, a); kscm__cdr(kscm, a) = p; p = a; a = q; } } return (p); } /* equivalence of atoms */ int kscm__eqv(kscm_t* kscm, register kscm_object_t a, register kscm_object_t b) { if (kscm__isstring(kscm, a)) { if (kscm__isstring(kscm, b)) return (!strcmp(kscm__strvalue(kscm, a), kscm__strvalue(kscm, b))); else return (0); } else if (kscm__isnumber(kscm, a)) { if (kscm__isnumber(kscm, b)) return (kscm__ivalue(kscm, a) == kscm__ivalue(kscm, b)); else return (0); } else return (a == b); } /* true or false value macro */ #define kscm__istrue(kscm,p) ((p) != kscm->NIL && (p) != kscm->F) #define kscm__isfalse(kscm,p) ((p) == kscm->NIL || (p) == kscm->F) /* Error macro */ #ifdef KSCM_CONFIG_AVOID_HACK_LOOP # define KSCM__BEGIN { # define KSCM__END } #else /* * I believe this is better, but some compiler complains.... */ # define KSCM__BEGIN do { # define KSCM__END } while (0) #endif #define kscm__error_0(kscm,s) KSCM__BEGIN \ kscm->args = kscm__cons(kscm, kscm__mk_string(kscm, (s)), kscm->NIL); \ kscm->_operator = (short)KSCM_OP_ERR0; \ return kscm->T; KSCM__END #define kscm__error_1(kscm,s, a) KSCM__BEGIN \ kscm->args = kscm__cons(kscm, (a), kscm->NIL); \ kscm->args = kscm__cons(kscm, kscm__mk_string(kscm, (s)), kscm->args); \ kscm->_operator = (short)KSCM_OP_ERR0; \ return kscm->T; KSCM__END /* control macros for Eval_Cycle */ #define kscm__s_goto(kscm,a) KSCM__BEGIN \ kscm->_operator = (short)(a); \ return kscm->T; KSCM__END #define kscm__s_save(kscm,a, b, c) do{ \ kscm->dump = kscm__cons(kscm, kscm->envir, kscm__cons(kscm, (c), kscm->dump)); \ kscm->dump = kscm__cons(kscm, (b), kscm->dump); \ kscm->dump = kscm__cons(kscm, kscm__mk_number(kscm, (long)(a)), kscm->dump);}while(0) #define kscm__s_return(kscm,a) KSCM__BEGIN \ kscm->value = (a); \ kscm->_operator = kscm__ivalue(kscm, kscm__car(kscm, kscm->dump)); \ kscm->args = kscm__cadr(kscm, kscm->dump); \ kscm->envir = kscm__caddr(kscm, kscm->dump); \ kscm->code = kscm__cadddr(kscm, kscm->dump); \ kscm->dump = kscm__cddddr(kscm, kscm->dump); \ return kscm->T; KSCM__END #define kscm__s_retbool(kscm,tf) kscm__s_return(kscm, (tf) ? kscm->T : kscm->F) kscm_object_t kscm__opexe_0(kscm_t* kscm, register short op) { register kscm_object_t x; register kscm_object_t y = NULL; switch (op) { case KSCM_OP_LOAD: /* load */ if (!kscm__isstring(kscm, kscm__car(kscm, kscm->args))) { kscm__error_0(kscm, "load -- argument is not string"); } if (kscm->inputtop + 1 >= KSCM_CONFIG_MAXLOADS) { kscm__error_0(kscm, "load -- depth of loaded files has reached the KSCM_CONFIG_MAXLOADS value"); } if ((kscm->inputs[kscm->inputtop + 1] = fopen(kscm__strvalue(kscm, kscm__car(kscm, kscm->args)), "r")) == NULL) { //kscm->inputs[kscm->inputtop] = stdin; kscm__error_1(kscm, "Unable to open", kscm__car(kscm, kscm->args)); } kscm->inputtop++; if (!kscm->quiet) fprintf(kscm->outfp, "loading %s", kscm__strvalue(kscm, kscm__car(kscm, kscm->args))); kscm__s_goto(kscm, KSCM_OP_T0LVL); case KSCM_OP_T0LVL: /* top level */ if (!kscm->quiet) fprintf(kscm->outfp, "\n"); kscm->dump = kscm->NIL; kscm->envir = kscm->global_env; kscm__s_save(kscm, KSCM_OP_VALUEPRINT, kscm->NIL, kscm->NIL); kscm__s_save(kscm, KSCM_OP_T1LVL, kscm->NIL, kscm->NIL); if (kscm->inputs[kscm->inputtop] == stdin && !kscm->quiet) {printf(KSCM_CONFIG_PROMPT);fflush(stdout);} kscm__s_goto(kscm, KSCM_OP_READ); case KSCM_OP_T1LVL: /* top level */ kscm->code = kscm->value; kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_READ: /* read */ kscm->tok = kscm__token(kscm); kscm__s_goto(kscm, KSCM_OP_RDSEXPR); case KSCM_OP_VALUEPRINT: /* print evalution result */ kscm->print_flag = 1; kscm->args = kscm->value; if (kscm->quiet) { kscm__s_goto(kscm, KSCM_OP_T0LVL); } else { kscm__s_save(kscm, KSCM_OP_T0LVL, kscm->NIL, kscm->NIL); kscm__s_goto(kscm, KSCM_OP_P0LIST); } case KSCM_OP_EVAL: /* main part of evalution */ if (kscm__issymbol(kscm, kscm->code)) { /* symbol */ for (x = kscm->envir; x != kscm->NIL; x = kscm__cdr(kscm, x)) { for (y = kscm__car(kscm, x); y != kscm->NIL; y = kscm__cdr(kscm, y)) if (kscm__caar(kscm, y) == kscm->code) break; if (y != kscm->NIL) break; } if (x != kscm->NIL) { kscm__s_return(kscm, kscm__cdar(kscm, y)); } else { kscm__error_1(kscm, "Unbounded variable", kscm->code); } } else if (kscm__ispair(kscm, kscm->code)) { if (kscm__issyntax(kscm, x = kscm__car(kscm, kscm->code))) { /* SYNTAX */ kscm->code = kscm__cdr(kscm, kscm->code); kscm__s_goto(kscm, kscm__syntaxnum(kscm, x)); } else {/* first, eval top element and eval arguments */ #ifdef KSCM_CONFIG_USE_MACRO kscm__s_save(kscm, KSCM_OP_E0ARGS, kscm->NIL, kscm->code); #else s_save(kscm, KSCM_OP_E1ARGS, kscm->NIL, cdr(code)); #endif kscm->code = kscm__car(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); } } else { kscm__s_return(kscm, kscm->code); } #ifdef KSCM_CONFIG_USE_MACRO case KSCM_OP_E0ARGS: /* eval arguments */ if (kscm__ismacro(kscm, kscm->value)) { /* macro expansion */ kscm__s_save(kscm, KSCM_OP_DOMACRO, kscm->NIL, kscm->NIL); kscm->args = kscm__cons(kscm, kscm->code, kscm->NIL); kscm->code = kscm->value; kscm__s_goto(kscm, KSCM_OP_APPLY); } else { kscm->code = kscm__cdr(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_E1ARGS); } #endif case KSCM_OP_E1ARGS: /* eval arguments */ kscm->args = kscm__cons(kscm, kscm->value, kscm->args); if (kscm__ispair(kscm, kscm->code)) { /* continue */ kscm__s_save(kscm, KSCM_OP_E1ARGS, kscm->args, kscm__cdr(kscm, kscm->code)); kscm->code = kscm__car(kscm, kscm->code); kscm->args = kscm->NIL; kscm__s_goto(kscm, KSCM_OP_EVAL); } else { /* end */ kscm->args = kscm__reverse(kscm, kscm->args); kscm->code = kscm__car(kscm, kscm->args); kscm->args = kscm__cdr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_APPLY); } case KSCM_OP_APPLY: /* apply 'code' to 'args' */ if (kscm__isproc(kscm, kscm->code)) { kscm__s_goto(kscm, kscm__procnum(kscm, kscm->code)); /* PROCEDURE */ } else if (kscm__isclosure(kscm, kscm->code)) { /* CLOSURE */ /* make environment */ kscm->envir = kscm__cons(kscm, kscm->NIL, kscm__closure_env(kscm, kscm->code)); y = kscm->args; for (x = kscm__car(kscm, kscm__closure_code(kscm, kscm->code))/*, y = kscm->args*/; kscm__ispair(kscm, x); x = kscm__cdr(kscm, x)/*, y = kscm__cdr(kscm, y)*/) { if (y == kscm->NIL) { kscm__error_0(kscm, "Few arguments"); } else { kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm__car(kscm, x), kscm__car(kscm, y)), kscm__car(kscm, kscm->envir)); } y = kscm__cdr(kscm, y); } if (x == kscm->NIL) { /*-- * if (y != kscm->NIL) { * Error_0("Many arguments"); * } */ } else if (kscm__issymbol(kscm, x)) kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, x, y), kscm__car(kscm, kscm->envir)); else { kscm__error_0(kscm, "Syntax error in closure"); } kscm->code = kscm__cdr(kscm, kscm__closure_code(kscm, kscm->code)); kscm->args = kscm->NIL; kscm__s_goto(kscm, KSCM_OP_BEGIN); } else if (kscm__iscontinuation(kscm, kscm->code)) { /* CONTINUATION */ kscm->dump = kscm__cont_dump(kscm, kscm->code); kscm__s_return(kscm, kscm->args != kscm->NIL ? kscm__car(kscm, kscm->args) : kscm->NIL); } else { kscm__error_0(kscm, "Illegal function"); } #ifdef KSCM_CONFIG_USE_MACRO case KSCM_OP_DOMACRO: /* do macro */ kscm->code = kscm->value; kscm__s_goto(kscm, KSCM_OP_EVAL); #endif case KSCM_OP_LAMBDA: /* lambda */ kscm__s_return(kscm, kscm__mk_closure(kscm, kscm->code, kscm->envir)); case KSCM_OP_QUOTE: /* quote */ kscm__s_return(kscm, kscm__car(kscm, kscm->code)); case KSCM_OP_DEF0: /* define */ if (kscm__ispair(kscm, kscm__car(kscm, kscm->code))) { x = kscm__caar(kscm, kscm->code); kscm->code = kscm__cons(kscm, kscm->LAMBDA, kscm__cons(kscm, kscm__cdar(kscm, kscm->code), kscm__cdr(kscm, kscm->code))); } else { x = kscm__car(kscm, kscm->code); kscm->code = kscm__cadr(kscm, kscm->code); } if (!kscm__issymbol(kscm, x)) { kscm__error_0(kscm, "Variable is not symbol"); } kscm__s_save(kscm, KSCM_OP_DEF1, kscm->NIL, x); kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_DEF1: /* define */ for (x = kscm__car(kscm, kscm->envir); x != kscm->NIL; x = kscm__cdr(kscm, x)) if (kscm__caar(kscm, x) == kscm->code) break; if (x != kscm->NIL) kscm__cdar(kscm, x) = kscm->value; else kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm->code, kscm->value), kscm__car(kscm, kscm->envir)); kscm__s_return(kscm, kscm->code); case KSCM_OP_SET0: /* set! */ kscm__s_save(kscm, KSCM_OP_SET1, kscm->NIL, kscm__car(kscm, kscm->code)); kscm->code = kscm__cadr(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_SET1: /* set! */ for (x = kscm->envir; x != kscm->NIL; x = kscm__cdr(kscm, x)) { for (y = kscm__car(kscm, x); y != kscm->NIL; y = kscm__cdr(kscm, y)) if (kscm__caar(kscm, y) == kscm->code) break; if (y != kscm->NIL) break; } if (x != kscm->NIL) { kscm__cdar(kscm, y) = kscm->value; kscm__s_return(kscm, kscm->value); } else { kscm__error_1(kscm, "Unbounded variable", kscm->code); } case KSCM_OP_BEGIN: /* begin */ if (!kscm__ispair(kscm, kscm->code)) { kscm__s_return(kscm, kscm->code); } if (kscm__cdr(kscm, kscm->code) != kscm->NIL) { kscm__s_save(kscm, KSCM_OP_BEGIN, kscm->NIL, kscm__cdr(kscm, kscm->code)); } kscm->code = kscm__car(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_IF0: /* if */ kscm__s_save(kscm, KSCM_OP_IF1, kscm->NIL, kscm__cdr(kscm, kscm->code)); kscm->code = kscm__car(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_IF1: /* if */ if (kscm__istrue(kscm, kscm->value)) kscm->code = kscm__car(kscm, kscm->code); else kscm->code = kscm__cadr(kscm, kscm->code); /* (if #f 1) ==> () because * car(kscm->NIL) = kscm->NIL */ kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_LET0: /* let */ kscm->args = kscm->NIL; kscm->value = kscm->code; kscm->code = kscm__issymbol(kscm, kscm__car(kscm, kscm->code)) ? kscm__cadr(kscm, kscm->code) : kscm__car(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_LET1); case KSCM_OP_LET1: /* let (caluculate parameters) */ kscm->args = kscm__cons(kscm, kscm->value, kscm->args); if (kscm__ispair(kscm, kscm->code)) { /* continue */ kscm__s_save(kscm, KSCM_OP_LET1, kscm->args, kscm__cdr(kscm, kscm->code)); kscm->code = kscm__cadar(kscm, kscm->code); kscm->args = kscm->NIL; kscm__s_goto(kscm, KSCM_OP_EVAL); } else { /* end */ kscm->args = kscm__reverse(kscm, kscm->args); kscm->code = kscm__car(kscm, kscm->args); kscm->args = kscm__cdr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_LET2); } case KSCM_OP_LET2: /* let */ kscm->envir = kscm__cons(kscm, kscm->NIL, kscm->envir); y = kscm->args; for (x = kscm__issymbol(kscm, kscm__car(kscm, kscm->code)) ? kscm__cadr(kscm, kscm->code) : kscm__car(kscm, kscm->code)/*, y = kscm->args*/; y != kscm->NIL; x = kscm__cdr(kscm, x)/*, y = kscm__cdr(kscm, y)*/) kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm__caar(kscm, x), kscm__car(kscm, y)), kscm__car(kscm, kscm->envir)); y = kscm__cdr(kscm, y); if (kscm__issymbol(kscm, kscm__car(kscm, kscm->code))) { /* named let */ kscm->args = kscm->NIL; for (x = kscm__cadr(kscm, kscm->code) /*, kscm->args = kscm->NIL*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) kscm->args = kscm__cons(kscm, kscm__caar(kscm, x), kscm->args); x = kscm__mk_closure(kscm, kscm__cons(kscm, kscm__reverse(kscm, kscm->args), kscm__cddr(kscm, kscm->code)), kscm->envir); kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm__car(kscm, kscm->code), x), kscm__car(kscm, kscm->envir)); kscm->code = kscm__cddr(kscm, kscm->code); kscm->args = kscm->NIL; } else { kscm->code = kscm__cdr(kscm, kscm->code); kscm->args = kscm->NIL; } kscm__s_goto(kscm, KSCM_OP_BEGIN); case KSCM_OP_LET0AST: /* let* */ if (kscm__car(kscm, kscm->code) == kscm->NIL) { kscm->envir = kscm__cons(kscm, kscm->NIL, kscm->envir); kscm->code = kscm__cdr(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_BEGIN); } kscm__s_save(kscm, KSCM_OP_LET1AST, kscm__cdr(kscm, kscm->code), kscm__car(kscm, kscm->code)); kscm->code = kscm__cadaar(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_LET1AST: /* let* (make new frame) */ kscm->envir = kscm__cons(kscm, kscm->NIL, kscm->envir); kscm__s_goto(kscm, KSCM_OP_LET2AST); case KSCM_OP_LET2AST: /* let* (caluculate parameters) */ kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm__caar(kscm, kscm->code), kscm->value), kscm__car(kscm, kscm->envir)); kscm->code = kscm__cdr(kscm, kscm->code); if (kscm__ispair(kscm, kscm->code)) { /* continue */ kscm__s_save(kscm, KSCM_OP_LET2AST, kscm->args, kscm->code); kscm->code = kscm__cadar(kscm, kscm->code); kscm->args = kscm->NIL; kscm__s_goto(kscm, KSCM_OP_EVAL); } else { /* end */ kscm->code = kscm->args; kscm->args = kscm->NIL; kscm__s_goto(kscm, KSCM_OP_BEGIN); } default: sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator); kscm__error_0(kscm, kscm->strbuff); } return kscm->T; } kscm_object_t kscm__opexe_1(kscm_t* kscm, register short op) { register kscm_object_t x, y; switch (op) { case KSCM_OP_LET0REC: /* letrec */ kscm->envir = kscm__cons(kscm, kscm->NIL, kscm->envir); kscm->args = kscm->NIL; kscm->value = kscm->code; kscm->code = kscm__car(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_LET1REC); case KSCM_OP_LET1REC: /* letrec (caluculate parameters) */ kscm->args = kscm__cons(kscm, kscm->value, kscm->args); if (kscm__ispair(kscm, kscm->code)) { /* continue */ kscm__s_save(kscm, KSCM_OP_LET1REC, kscm->args, kscm__cdr(kscm, kscm->code)); kscm->code = kscm__cadar(kscm, kscm->code); kscm->args = kscm->NIL; kscm__s_goto(kscm, KSCM_OP_EVAL); } else { /* end */ kscm->args = kscm__reverse(kscm, kscm->args); kscm->code = kscm__car(kscm, kscm->args); kscm->args = kscm__cdr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_LET2REC); } case KSCM_OP_LET2REC: /* letrec */ y = kscm->args; for (x = kscm__car(kscm, kscm->code)/*, y = kscm->args*/; y != kscm->NIL; x = kscm__cdr(kscm, x)/*, y = kscm__cdr(kscm, y)*/) { kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm__caar(kscm, x), kscm__car(kscm, y)), kscm__car(kscm, kscm->envir)); y = kscm__cdr(kscm, y); } kscm->code = kscm__cdr(kscm, kscm->code); kscm->args = kscm->NIL; kscm__s_goto(kscm, KSCM_OP_BEGIN); case KSCM_OP_COND0: /* cond */ if (!kscm__ispair(kscm, kscm->code)) { kscm__error_0(kscm, "Syntax error in cond"); } kscm__s_save(kscm, KSCM_OP_COND1, kscm->NIL, kscm->code); kscm->code = kscm__caar(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_COND1: /* cond */ if (kscm__istrue(kscm, kscm->value)) { if ((kscm->code = kscm__cdar(kscm, kscm->code)) == kscm->NIL) { kscm__s_return(kscm, kscm->value); } kscm__s_goto(kscm, KSCM_OP_BEGIN); } else { if ((kscm->code = kscm__cdr(kscm, kscm->code)) == kscm->NIL) { kscm__s_return(kscm, kscm->NIL); } else { kscm__s_save(kscm, KSCM_OP_COND1, kscm->NIL, kscm->code); kscm->code = kscm__caar(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); } } case KSCM_OP_DELAY: /* delay */ x = kscm__mk_closure(kscm, kscm__cons(kscm, kscm->NIL, kscm->code), kscm->envir); kscm__setpromise(kscm, x); kscm__s_return(kscm, x); case KSCM_OP_AND0: /* and */ if (kscm->code == kscm->NIL) { kscm__s_return(kscm, kscm->T); } kscm__s_save(kscm, KSCM_OP_AND1, kscm->NIL, kscm__cdr(kscm, kscm->code)); kscm->code = kscm__car(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_AND1: /* and */ if (kscm__isfalse(kscm, kscm->value)) { kscm__s_return(kscm, kscm->value); } else if (kscm->code == kscm->NIL) { kscm__s_return(kscm, kscm->value); } else { kscm__s_save(kscm, KSCM_OP_AND1, kscm->NIL, kscm__cdr(kscm, kscm->code)); kscm->code = kscm__car(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); } case KSCM_OP_OR0: /* or */ if (kscm->code == kscm->NIL) { kscm__s_return(kscm, kscm->F); } kscm__s_save(kscm, KSCM_OP_OR1, kscm->NIL, kscm__cdr(kscm, kscm->code)); kscm->code = kscm__car(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_OR1: /* or */ if (kscm__istrue(kscm, kscm->value)) { kscm__s_return(kscm, kscm->value); } else if (kscm->code == kscm->NIL) { kscm__s_return(kscm, kscm->value); } else { kscm__s_save(kscm, KSCM_OP_OR1, kscm->NIL, kscm__cdr(kscm, kscm->code)); kscm->code = kscm__car(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); } case KSCM_OP_C0STREAM: /* cons-stream */ kscm__s_save(kscm, KSCM_OP_C1STREAM, kscm->NIL, kscm__cdr(kscm, kscm->code)); kscm->code = kscm__car(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_C1STREAM: /* cons-stream */ kscm->args = kscm->value; /* save value to register args for gc */ x = kscm__mk_closure(kscm, kscm__cons(kscm, kscm->NIL, kscm->code), kscm->envir); kscm__setpromise(kscm, x); kscm__s_return(kscm, kscm__cons(kscm, kscm->args, x)); #ifdef KSCM_CONFIG_USE_MACRO case KSCM_OP_0MACRO: /* macro */ x = kscm__car(kscm, kscm->code); kscm->code = kscm__cadr(kscm, kscm->code); if (!kscm__issymbol(kscm, x)) { kscm__error_0(kscm, "Variable is not symbol"); } kscm__s_save(kscm, KSCM_OP_1MACRO, kscm->NIL, x); kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_1MACRO: /* macro */ kscm__type(kscm, kscm->value) |= KSCM_T_MACRO; for (x = kscm__car(kscm, kscm->envir); x != kscm->NIL; x = kscm__cdr(kscm, x)) if (kscm__caar(kscm, x) == kscm->code) break; if (x != kscm->NIL) kscm__cdar(kscm, x) = kscm->value; else kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm->code, kscm->value), kscm__car(kscm, kscm->envir)); kscm__s_return(kscm, kscm->code); #endif case KSCM_OP_CASE0: /* case */ kscm__s_save(kscm, KSCM_OP_CASE1, kscm->NIL, kscm__cdr(kscm, kscm->code)); kscm->code = kscm__car(kscm, kscm->code); kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_CASE1: /* case */ for (x = kscm->code; x != kscm->NIL; x = kscm__cdr(kscm, x)) { if (!kscm__ispair(kscm, y = kscm__caar(kscm, x))) break; for (; y != kscm->NIL; y = kscm__cdr(kscm, y)) if (kscm__eqv(kscm, kscm__car(kscm, y), kscm->value)) break; if (y != kscm->NIL) break; } if (x != kscm->NIL) { if (kscm__ispair(kscm, kscm__caar(kscm, x))) { kscm->code = kscm__cdar(kscm, x); kscm__s_goto(kscm, KSCM_OP_BEGIN); } else {/* else */ kscm__s_save(kscm, KSCM_OP_CASE2, kscm->NIL, kscm__cdar(kscm, x)); kscm->code = kscm__caar(kscm, x); kscm__s_goto(kscm, KSCM_OP_EVAL); } } else { kscm__s_return(kscm, kscm->NIL); } case KSCM_OP_CASE2: /* case */ if (kscm__istrue(kscm, kscm->value)) { kscm__s_goto(kscm, KSCM_OP_BEGIN); } else { kscm__s_return(kscm, kscm->NIL); } case KSCM_OP_PAPPLY: /* apply */ kscm->code = kscm__car(kscm, kscm->args); kscm->args = kscm__cadr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_APPLY); case KSCM_OP_PEVAL: /* eval */ kscm->code = kscm__car(kscm, kscm->args); kscm->args = kscm->NIL; kscm__s_goto(kscm, KSCM_OP_EVAL); case KSCM_OP_CONTINUATION: /* call-with-current-continuation */ kscm->code = kscm__car(kscm, kscm->args); kscm->args = kscm__cons(kscm, kscm__mk_continuation(kscm, kscm->dump), kscm->NIL); kscm__s_goto(kscm, KSCM_OP_APPLY); default: sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator); kscm__error_0(kscm, kscm->strbuff); } return kscm->T; } kscm_object_t kscm__opexe_2(kscm_t* kscm, register short op) { register kscm_object_t x, y; #ifdef KSCM_CONFIG_USE_PRECISE int32_t v; #else register long v; #endif switch (op) { case KSCM_OP_ADD: /* + */ v = 0; for (x = kscm->args/*, v = 0*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) { if (!kscm__isnumber(kscm, kscm__car(kscm, x))) { kscm__s_retbool(kscm, 0); } #ifdef KSCM_CONFIG_USE_PRECISE int64_t lv = ((int64_t)v) + ((int64_t)kscm__ivalue(kscm, kscm__car(kscm, x))); v = (int32_t)lv; if (((int64_t)v) != lv) { kscm__s_retbool(kscm, 0); } #else v += kscm__ivalue(kscm, kscm__car(kscm, x)); #endif } kscm__s_return(kscm, kscm__mk_number(kscm, v)); case KSCM_OP_SUB: /* - */ v = v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args)); for (x = kscm__cdr(kscm, kscm->args)/*, v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args))*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) { if (!kscm__isnumber(kscm, kscm__car(kscm, x))) { kscm__s_retbool(kscm, 0); } #ifdef KSCM_CONFIG_USE_PRECISE int64_t lv = ((int64_t)v) - ((int64_t)kscm__ivalue(kscm, kscm__car(kscm, x))); v = (int32_t)lv; if (((int64_t)v) != lv) { kscm__s_retbool(kscm, 0); } #else v -= kscm__ivalue(kscm, kscm__car(kscm, x)); #endif } kscm__s_return(kscm, kscm__mk_number(kscm, v)); case KSCM_OP_MUL: /* * */ v = 1; for (x = kscm->args/*, v = 1*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) { if (!kscm__isnumber(kscm, kscm__car(kscm, x))) { kscm__s_retbool(kscm, 0); } #ifdef KSCM_CONFIG_USE_PRECISE int64_t lv = ((int64_t)v) * ((int64_t)kscm__ivalue(kscm, kscm__car(kscm, x))); v = (int32_t)lv; if (((int64_t)v) != lv) { kscm__s_retbool(kscm, 0); } #else v *= kscm__ivalue(kscm, kscm__car(kscm, x)); #endif } kscm__s_return(kscm, kscm__mk_number(kscm, v)); case KSCM_OP_DIV: /* / */ v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args)); for (x = kscm__cdr(kscm, kscm->args)/*, v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args))*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) { if (!kscm__isnumber(kscm, kscm__car(kscm, x))) { kscm__s_retbool(kscm, 0); } if (kscm__ivalue(kscm, kscm__car(kscm, x)) != 0) v /= kscm__ivalue(kscm, kscm__car(kscm, x)); else { #ifdef KSCM_CONFIG_USE_PRECISE kscm__s_retbool(kscm, 0); #else kscm__error_0(kscm, "Divided by zero"); #endif } } kscm__s_return(kscm, kscm__mk_number(kscm, v)); case KSCM_OP_REM: /* remainder */ v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args)); for (x = kscm__cdr(kscm, kscm->args)/*, v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args))*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) { if (!kscm__isnumber(kscm, kscm__car(kscm, x))) { kscm__s_retbool(kscm, 0); } if (kscm__ivalue(kscm, kscm__car(kscm, x)) != 0) v %= kscm__ivalue(kscm, kscm__car(kscm, x)); else { #ifdef KSCM_CONFIG_USE_PRECISE kscm__s_retbool(kscm, 0); #else kscm__error_0(kscm, "Divided by zero"); #endif } } kscm__s_return(kscm, kscm__mk_number(kscm, v)); case KSCM_OP_CAR: /* car */ if (kscm__ispair(kscm, kscm__car(kscm, kscm->args))) { kscm__s_return(kscm, kscm__caar(kscm, kscm->args)); } else { kscm__error_0(kscm, "Unable to car for non-cons cell"); } case KSCM_OP_CDR: /* cdr */ if (kscm__ispair(kscm, kscm__car(kscm, kscm->args))) { kscm__s_return(kscm, kscm__cdar(kscm, kscm->args)); } else { kscm__error_0(kscm, "Unable to cdr for non-cons cell"); } case KSCM_OP_CONS: /* cons */ kscm__cdr(kscm, kscm->args) = kscm__cadr(kscm, kscm->args); kscm__s_return(kscm, kscm->args); case KSCM_OP_SETCAR: /* set-car! */ if (kscm__ispair(kscm, kscm__car(kscm, kscm->args))) { kscm__caar(kscm, kscm->args) = kscm__cadr(kscm, kscm->args); kscm__s_return(kscm, kscm__car(kscm, kscm->args)); } else { kscm__error_0(kscm, "Unable to set-car! for non-cons cell"); } case KSCM_OP_SETCDR: /* set-cdr! */ if (kscm__ispair(kscm, kscm__car(kscm, kscm->args))) { kscm__cdar(kscm, kscm->args) = kscm__cadr(kscm, kscm->args); kscm__s_return(kscm, kscm__car(kscm, kscm->args)); } else { kscm__error_0(kscm, "Unable to set-cdr! for non-cons cell"); } default: sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator); kscm__error_0(kscm, kscm->strbuff); } return kscm->T; } kscm_object_t kscm__opexe_3(kscm_t* kscm, register short op) { register kscm_object_t x, y; switch (op) { case KSCM_OP_NOT: /* not */ kscm__s_retbool(kscm, kscm__isfalse(kscm, kscm__car(kscm, kscm->args))); case KSCM_OP_BOOL: /* boolean? */ kscm__s_retbool(kscm, kscm__car(kscm, kscm->args) == kscm->F || kscm__car(kscm, kscm->args) == kscm->T); case KSCM_OP_NULL: /* null? */ kscm__s_retbool(kscm, kscm__car(kscm, kscm->args) == kscm->NIL); case KSCM_OP_ZEROP: /* zero? */ kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) == 0); case KSCM_OP_POSP: /* positive? */ kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) > 0); case KSCM_OP_NEGP: /* negative? */ kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) < 0); case KSCM_OP_NEQ: /* = */ kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) == kscm__ivalue(kscm, kscm__cadr(kscm, kscm->args))); case KSCM_OP_LESS: /* < */ kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) < kscm__ivalue(kscm, kscm__cadr(kscm, kscm->args))); case KSCM_OP_GRE: /* > */ kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) > kscm__ivalue(kscm, kscm__cadr(kscm, kscm->args))); case KSCM_OP_LEQ: /* <= */ kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) <= kscm__ivalue(kscm, kscm__cadr(kscm, kscm->args))); case KSCM_OP_GEQ: /* >= */ kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) >= kscm__ivalue(kscm, kscm__cadr(kscm, kscm->args))); case KSCM_OP_SYMBOL: /* symbol? */ kscm__s_retbool(kscm, kscm__issymbol(kscm, kscm__car(kscm, kscm->args))); case KSCM_OP_NUMBER: /* number? */ kscm__s_retbool(kscm, kscm__isnumber(kscm, kscm__car(kscm, kscm->args))); case KSCM_OP_STRING: /* string? */ kscm__s_retbool(kscm, kscm__isstring(kscm, kscm__car(kscm, kscm->args))); case KSCM_OP_PROC: /* procedure? */ /*-- * continuation should be procedure by the example * (call-with-current-continuation procedure?) ==> #t * in R^3 report sec. 6.9 */ kscm__s_retbool(kscm, kscm__isproc(kscm, kscm__car(kscm, kscm->args)) || kscm__isclosure(kscm, kscm__car(kscm, kscm->args)) || kscm__iscontinuation(kscm, kscm__car(kscm, kscm->args))); case KSCM_OP_PAIR: /* pair? */ kscm__s_retbool(kscm, kscm__ispair(kscm, kscm__car(kscm, kscm->args))); case KSCM_OP_EQ: /* eq? */ kscm__s_retbool(kscm, kscm__car(kscm, kscm->args) == kscm__cadr(kscm, kscm->args)); case KSCM_OP_EQV: /* eqv? */ kscm__s_retbool(kscm, kscm__eqv(kscm, kscm__car(kscm, kscm->args), kscm__cadr(kscm, kscm->args))); default: sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator); kscm__error_0(kscm, kscm->strbuff); } return kscm->T; } kscm_object_t kscm__opexe_4(kscm_t* kscm, register short op) { register kscm_object_t x, y; switch (op) { case KSCM_OP_FORCE: /* force */ kscm->code = kscm__car(kscm, kscm->args); if (kscm__ispromise(kscm, kscm->code)) { kscm->args = kscm->NIL; kscm__s_goto(kscm, KSCM_OP_APPLY); } else { kscm__s_return(kscm, kscm->code); } case KSCM_OP_WRITE: /* write */ kscm->print_flag = 1; kscm->args = kscm__car(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0LIST); case KSCM_OP_DISPLAY: /* display */ kscm->print_flag = 0; kscm->args = kscm__car(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0LIST); case KSCM_OP_NEWLINE: /* newline */ fprintf(kscm->outfp, "\n"); kscm__s_return(kscm, kscm->T); case KSCM_OP_ERR0: /* error */ if (!kscm__isstring(kscm, kscm__car(kscm, kscm->args))) { kscm__error_0(kscm, "error -- first argument must be string"); } kscm->tmpfp = kscm->outfp; kscm->outfp = stderr; if (kscm->all_errors_fatal) { kscm__fatal_error(kscm, kscm__strvalue(kscm, kscm__car(kscm, kscm->args)), NULL, NULL, NULL); } fprintf(kscm->outfp, "Error: "); fprintf(kscm->outfp, "%s", kscm__strvalue(kscm, kscm__car(kscm, kscm->args))); kscm->args = kscm__cdr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_ERR1); case KSCM_OP_ERR1: /* error */ fprintf(kscm->outfp, " "); if (kscm->args != kscm->NIL) { kscm__s_save(kscm, KSCM_OP_ERR1, kscm__cdr(kscm, kscm->args), kscm->NIL); kscm->args = kscm__car(kscm, kscm->args); kscm->print_flag = 1; kscm__s_goto(kscm, KSCM_OP_P0LIST); } else { fprintf(kscm->outfp, "\n"); kscm__resetinput(kscm); kscm->outfp = kscm->tmpfp; kscm__s_goto(kscm, KSCM_OP_T0LVL); } case KSCM_OP_REVERSE: /* reverse */ kscm__s_return(kscm, kscm__reverse(kscm, kscm__car(kscm, kscm->args))); case KSCM_OP_APPEND: /* append */ kscm__s_return(kscm, kscm__append(kscm, kscm__car(kscm, kscm->args), kscm__cadr(kscm, kscm->args))); case KSCM_OP_PUT: /* put */ if (!kscm__hasprop(kscm, kscm__car(kscm, kscm->args)) || !kscm__hasprop(kscm, kscm__cadr(kscm, kscm->args))) { kscm__error_0(kscm, "Illegal use of put"); } y = kscm__cadr(kscm, kscm->args); for (x = kscm__symprop(kscm, kscm__car(kscm, kscm->args))/*, y = kscm__cadr(kscm, kscm->args)*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) if (kscm__caar(kscm, x) == y) break; if (x != kscm->NIL) kscm__cdar(kscm, x) = kscm__caddr(kscm, kscm->args); else kscm__symprop(kscm, kscm__car(kscm, kscm->args)) = kscm__cons(kscm, kscm__cons(kscm, y, kscm__caddr(kscm, kscm->args)), kscm__symprop(kscm, kscm__car(kscm, kscm->args))); kscm__s_return(kscm, kscm->T); case KSCM_OP_GET: /* get */ if (!kscm__hasprop(kscm, kscm__car(kscm, kscm->args)) || !kscm__hasprop(kscm, kscm__cadr(kscm, kscm->args))) { kscm__error_0(kscm, "Illegal use of get"); } y = kscm__cadr(kscm, kscm->args); for (x = kscm__symprop(kscm, kscm__car(kscm, kscm->args))/*, y = kscm__cadr(kscm, kscm->args)*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) if (kscm__caar(kscm, x) == y) break; if (x != kscm->NIL) { kscm__s_return(kscm, kscm__cdar(kscm, x)); } else { kscm__s_return(kscm, kscm->NIL); } case KSCM_OP_QUIT: /* quit */ return (kscm->NIL); case KSCM_OP_GC: /* gc */ kscm__gc(kscm, kscm->NIL, kscm->NIL); kscm__s_return(kscm, kscm->T); case KSCM_OP_GCVERB: /* gc-verbose */ { int was = kscm->gc_verbose; kscm->gc_verbose = (kscm__car(kscm, kscm->args) != kscm->F); kscm__s_retbool(kscm, was); } case KSCM_OP_NEWSEGMENT: /* new-segment */ if (!kscm__isnumber(kscm, kscm__car(kscm, kscm->args))) { kscm__error_0(kscm, "new-segment -- argument must be number"); } fprintf(kscm->outfp, "allocate %d new segments\n", kscm__alloc_cellseg(kscm, (int)kscm__ivalue(kscm, kscm__car(kscm, kscm->args)))); kscm__s_return(kscm, kscm->T); } } kscm_object_t kscm__opexe_5(kscm_t* kscm, register short op) { register kscm_object_t x, y; switch (op) { /* ========== reading part ========== */ case KSCM_OP_RDSEXPR: switch (kscm->tok) { case KSCM_TOK_COMMENT: while (kscm__inchar(kscm) != '\n') ; kscm->tok = kscm__token(kscm); kscm__s_goto(kscm, KSCM_OP_RDSEXPR); case KSCM_TOK_LPAREN: kscm->tok = kscm__token(kscm); if (kscm->tok == KSCM_TOK_RPAREN) { kscm__s_return(kscm, kscm->NIL); } else if (kscm->tok == KSCM_TOK_DOT) { kscm__error_0(kscm, "syntax error -- illegal dot expression"); } else { kscm__s_save(kscm, KSCM_OP_RDLIST, kscm->NIL, kscm->NIL); kscm__s_goto(kscm, KSCM_OP_RDSEXPR); } case KSCM_TOK_QUOTE: kscm__s_save(kscm, KSCM_OP_RDQUOTE, kscm->NIL, kscm->NIL); kscm->tok = kscm__token(kscm); kscm__s_goto(kscm, KSCM_OP_RDSEXPR); #ifdef KSCM_CONFIG_USE_QQUOTE case KSCM_TOK_BQUOTE: kscm__s_save(kscm, KSCM_OP_RDQQUOTE, kscm->NIL, kscm->NIL); kscm->tok = kscm__token(kscm); kscm__s_goto(kscm, KSCM_OP_RDSEXPR); case KSCM_TOK_COMMA: kscm__s_save(kscm, KSCM_OP_RDUNQUOTE, kscm->NIL, kscm->NIL); kscm->tok = kscm__token(kscm); kscm__s_goto(kscm, KSCM_OP_RDSEXPR); case KSCM_TOK_ATMARK: kscm__s_save(kscm, KSCM_OP_RDUQTSP, kscm->NIL, kscm->NIL); kscm->tok = kscm__token(kscm); kscm__s_goto(kscm, KSCM_OP_RDSEXPR); #endif case KSCM_TOK_ATOM: kscm__s_return(kscm, kscm__mk_atom(kscm, kscm__readstr(kscm, "();\t\n "))); case KSCM_TOK_DQUOTE: kscm__s_return(kscm, kscm__mk_string(kscm, kscm__readstrexp(kscm))); case KSCM_TOK_SHARP: if ((x = kscm__mk_const(kscm, kscm__readstr(kscm, "();\t\n "))) == kscm->NIL) { kscm__error_0(kscm, "Undefined sharp expression"); } else { kscm__s_return(kscm, x); } default: kscm__error_0(kscm, "syntax error -- illegal token"); } break; case KSCM_OP_RDLIST: kscm->args = kscm__cons(kscm, kscm->value, kscm->args); kscm->tok = kscm__token(kscm); if (kscm->tok == KSCM_TOK_COMMENT) { while (kscm__inchar(kscm) != '\n') ; kscm->tok = kscm__token(kscm); } if (kscm->tok == KSCM_TOK_RPAREN) { kscm__s_return(kscm, kscm__non_alloc_rev(kscm, kscm->NIL, kscm->args)); } else if (kscm->tok == KSCM_TOK_DOT) { kscm__s_save(kscm, KSCM_OP_RDDOT, kscm->args, kscm->NIL); kscm->tok = kscm__token(kscm); kscm__s_goto(kscm, KSCM_OP_RDSEXPR); } else { kscm__s_save(kscm, KSCM_OP_RDLIST, kscm->args, kscm->NIL);; kscm__s_goto(kscm, KSCM_OP_RDSEXPR); } case KSCM_OP_RDDOT: if (kscm__token(kscm) != KSCM_TOK_RPAREN) { kscm__error_0(kscm, "syntax error -- illegal dot expression"); } else { kscm__s_return(kscm, kscm__non_alloc_rev(kscm, kscm->value, kscm->args)); } case KSCM_OP_RDQUOTE: kscm__s_return(kscm, kscm__cons(kscm, kscm->QUOTE, kscm__cons(kscm, kscm->value, kscm->NIL))); #ifdef KSCM_CONFIG_USE_QQUOTE case KSCM_OP_RDQQUOTE: kscm__s_return(kscm, kscm__cons(kscm, kscm->QQUOTE, kscm__cons(kscm, kscm->value, kscm->NIL))); case KSCM_OP_RDUNQUOTE: kscm__s_return(kscm, kscm__cons(kscm, kscm->UNQUOTE, kscm__cons(kscm, kscm->value, kscm->NIL))); case KSCM_OP_RDUQTSP: kscm__s_return(kscm, kscm__cons(kscm, kscm->UNQUOTESP, kscm__cons(kscm, kscm->value, kscm->NIL))); #endif /* ========== printing part ========== */ case KSCM_OP_P0LIST: if (!kscm__ispair(kscm, kscm->args)) { kscm__printatom(kscm, kscm->args, kscm->print_flag); kscm__s_return(kscm, kscm->T); } else if (kscm__car(kscm, kscm->args) == kscm->QUOTE && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) { fprintf(kscm->outfp, "'"); kscm->args = kscm__cadr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0LIST); } else if (kscm__car(kscm, kscm->args) == kscm->QQUOTE && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) { fprintf(kscm->outfp, "`"); kscm->args = kscm__cadr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0LIST); } else if (kscm__car(kscm, kscm->args) == kscm->UNQUOTE && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) { fprintf(kscm->outfp, ","); kscm->args = kscm__cadr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0LIST); } else if (kscm__car(kscm, kscm->args) == kscm->UNQUOTESP && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) { fprintf(kscm->outfp, ",@"); kscm->args = kscm__cadr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0LIST); } else { fprintf(kscm->outfp, "("); kscm__s_save(kscm, KSCM_OP_P1LIST, kscm__cdr(kscm, kscm->args), kscm->NIL); kscm->args = kscm__car(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0LIST); } case KSCM_OP_P1LIST: if (kscm__ispair(kscm, kscm->args)) { kscm__s_save(kscm, KSCM_OP_P1LIST, kscm__cdr(kscm, kscm->args), kscm->NIL); fprintf(kscm->outfp, " "); kscm->args = kscm__car(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0LIST); } else { if (kscm->args != kscm->NIL) { fprintf(kscm->outfp, " . "); kscm__printatom(kscm, kscm->args, kscm->print_flag); } fprintf(kscm->outfp, ")"); kscm__s_return(kscm, kscm->T); } default: sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator); kscm__error_0(kscm, kscm->strbuff); } return kscm->T; } kscm_object_t kscm__opexe_6(kscm_t* kscm, register short op) { register kscm_object_t x, y; register long v; static long w; char buffer[32]; switch (op) { case KSCM_OP_LIST_LENGTH: /* list-length */ /* a.k */ v = 0; for (x = kscm__car(kscm, kscm->args)/*, v = 0*/; kscm__ispair(kscm, x); x = kscm__cdr(kscm, x)) ++v; kscm__s_return(kscm, kscm__mk_number(kscm, v)); case KSCM_OP_ASSQ: /* assq */ /* a.k */ x = kscm__car(kscm, kscm->args); for (y = kscm__cadr(kscm, kscm->args); kscm__ispair(kscm, y); y = kscm__cdr(kscm, y)) { if (!kscm__ispair(kscm, kscm__car(kscm, y))) { kscm__error_0(kscm, "Unable to handle non pair element"); } if (x == kscm__caar(kscm, y)) break; } if (kscm__ispair(kscm, y)) { kscm__s_return(kscm, kscm__car(kscm, y)); } else { kscm__s_return(kscm, kscm->F); } case KSCM_OP_PRINT_WIDTH: /* print-width */ /* a.k */ w = 0; kscm->args = kscm__car(kscm, kscm->args); kscm->print_flag = -1; kscm__s_goto(kscm, KSCM_OP_P0_WIDTH); case KSCM_OP_P0_WIDTH: if (!kscm__ispair(kscm, kscm->args)) { w += kscm__printatom(kscm, kscm->args, kscm->print_flag); kscm__s_return(kscm, kscm__mk_number(kscm, w)); } else if (kscm__car(kscm, kscm->args) == kscm->QUOTE && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) { ++w; kscm->args = kscm__cadr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0_WIDTH); } else if (kscm__car(kscm, kscm->args) == kscm->QQUOTE && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) { ++w; kscm->args = kscm__cadr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0_WIDTH); } else if (kscm__car(kscm, kscm->args) == kscm->UNQUOTE && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) { ++w; kscm->args = kscm__cadr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0_WIDTH); } else if (kscm__car(kscm, kscm->args) == kscm->UNQUOTESP && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) { w += 2; kscm->args = kscm__cadr(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0_WIDTH); } else { ++w; kscm__s_save(kscm, KSCM_OP_P1_WIDTH, kscm__cdr(kscm, kscm->args), kscm->NIL); kscm->args = kscm__car(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0_WIDTH); } case KSCM_OP_P1_WIDTH: if (kscm__ispair(kscm, kscm->args)) { kscm__s_save(kscm, KSCM_OP_P1_WIDTH, kscm__cdr(kscm, kscm->args), kscm->NIL); ++w; kscm->args = kscm__car(kscm, kscm->args); kscm__s_goto(kscm, KSCM_OP_P0_WIDTH); } else { if (kscm->args != kscm->NIL) w += 3 + kscm__printatom(kscm, kscm->args, kscm->print_flag); ++w; kscm__s_return(kscm, kscm__mk_number(kscm, w)); } case KSCM_OP_GET_CLOSURE: /* get-closure-code */ /* a.k */ kscm->args = kscm__car(kscm, kscm->args); if (kscm->args == kscm->NIL) { kscm__s_return(kscm, kscm->F); } else if (kscm__isclosure(kscm, kscm->args)) { kscm__s_return(kscm, kscm__cons(kscm, kscm->LAMBDA, kscm__closure_code(kscm, kscm->value))); #ifdef KSCM_CONFIG_USE_MACRO } else if (kscm__ismacro(kscm, kscm->args)) { kscm__s_return(kscm, kscm__cons(kscm, kscm->LAMBDA, kscm__closure_code(kscm, kscm->value))); #endif } else { kscm__s_return(kscm, kscm->F); } case KSCM_OP_CLOSUREP: /* closure? */ /* * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t */ if (kscm__car(kscm, kscm->args) == kscm->NIL) { kscm__s_return(kscm, kscm->F); } kscm__s_retbool(kscm, kscm__isclosure(kscm, kscm__car(kscm, kscm->args))); #ifdef KSCM_CONFIG_USE_MACRO case KSCM_OP_MACROP: /* macro? */ if (kscm__car(kscm, kscm->args) == kscm->NIL) { kscm__s_return(kscm, kscm->F); } kscm__s_retbool(kscm, kscm__ismacro(kscm, kscm__car(kscm, kscm->args))); #endif default: sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator); kscm__error_0(kscm, kscm->strbuff); } return kscm->T; /* NOTREACHED */ } #ifdef KSCM_CONFIG_USE_PERSIST unsigned int kscm_get_persistent_address(kscm_t* kscm, kscm_object_t obj) { int i; if (obj == kscm->NIL) { return 0; } else if (obj == kscm->F) { return 1; } else if (obj == kscm->T) { return 2; } uintptr_t addr = (uintptr_t)obj; //fprintf(stderr, "addr is %d\n", addr); for (i = 0; i <= kscm->last_cell_seg; i++) { uintptr_t segaddr = (uintptr_t)(kscm->cell_seg[i]); //fprintf(stderr, "segaddr %d is %d\n", i, segaddr); if (segaddr != 0 && addr >= segaddr && addr < segaddr + (KSCM_CONFIG_CELL_SEGSIZE * sizeof(struct kscm_cell))) { //fprintf(stderr, "it's in here!\n"); int segment = i + 1; uintptr_t offset = addr - segaddr; if ((offset % sizeof(struct kscm_cell))) { return -1; } int index = offset / sizeof(struct kscm_cell); return (segment * KSCM_CONFIG_CELL_SEGSIZE) + index; } } return -1; } int kscm__fwrite_byte(kscm_t* kscm, FILE* f, char val) { fputc(val, f); return 1; } int kscm__fwrite_int(kscm_t* kscm, FILE* f, int val) { //fprintf(stderr, "writing %x %x %x %x\n", val & 0xFF, (val >> 8) & 0xFF, (val >> 16) & 0xFF, (val >> 24) & 0xFF); fputc((val & 0xFF), f); fputc(((val >> 8) & 0xFF), f); fputc(((val >> 16) & 0xFF), f); fputc(((val >> 24) & 0xFF), f); return 4; } int kscm__fwrite_strl(kscm_t* kscm, FILE* f, const char* str, int len) { if (str == NULL) { return kscm__fwrite_int(kscm, f, 0); } int written = kscm__fwrite_int(kscm, f, len); if (written != 4) { return written; } int i; for (i = 0; i < len; i++) { fputc(str[i], f); written++; } return written; } int kscm__fwrite_str(kscm_t* kscm, FILE* f, const char* str) { return kscm__fwrite_strl(kscm, f, str, strlen(str)); } int kscm_save_state(kscm_t* kscm, const char* filename, const char* opts) { if (filename == NULL || strlen(filename) < 1) { fprintf(stderr, "Filename expected\n"); return -1; } FILE* f = fopen(filename, "wb"); if (f == NULL) { fprintf(stderr, "Failed to open '%s' for writing\n", filename); return -1; // Not saved } fprintf(stderr, "Saving state to '%s' opts '%s'...\n", filename, opts); kscm__fwrite_str(kscm, f, KSCM_CONFIG_PERSIST_MAGIC); //fclose(f); if (1) return 0; kscm__fwrite_int(kscm, f, KSCM_CONFIG_PERSIST_VERSION); // Bytes per id (higher bits may be reused later for flags) kscm__fwrite_int(kscm, f, kscm->_stateformat); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->NIL)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->F)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->T)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->oblist)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->global_env)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->LAMBDA)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->QUOTE)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->QQUOTE)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->UNQUOTE)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->UNQUOTESP)); /* NOTE: The format has been reorganised (as of "version 2" of the format) to allow for * multithreading, which isn't supported on this implementation, but now thread-specific * data is stored separately. */ /* Begin by writing the number of threads (always 1, for now). */ kscm__fwrite_int(kscm, f, 1); kscm__fwrite_int(kscm, f, kscm->_threadstate); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadname)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadopts)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadobject)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->args)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->envir)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->code)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->dump)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->value)); kscm__fwrite_int(kscm, f, kscm->_operator); //fprintf(stderr, "Persistent addresses: ->T=%d ->F=%d ->NIL=%d\n", kscm_get_persistent_address(kscm, kscm->T), kscm_get_persistent_address(kscm, kscm->F), kscm_get_persistent_address(kscm, kscm->NIL)); //fprintf(stderr, "Persistent addresses: ->args=%d ->envir=%d ->code=%d ->dump=%d\n", kscm_get_persistent_address(kscm, kscm->args), kscm_get_persistent_address(kscm, kscm->envir), kscm_get_persistent_address(kscm, kscm->code), kscm_get_persistent_address(kscm, kscm->dump)); int s; for (s = 0; s <= kscm->last_cell_seg; s++) { fprintf(stderr, "."); int i; for (i = 0; i < KSCM_CONFIG_CELL_SEGSIZE; i++) { kscm_object_t obj = (kscm->cell_seg[s])+i;//&(kscm->cell_seg[s][i]); if (obj->_flag == 0) { // free ? //fprintf(stderr, "Object at %d:%d is free\n", s, i); } else { fprintf(stderr, "Object at %d:%d is non-free\n", s, i); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, obj)); if (kscm__isnumber(kscm, obj)) { if (!kscm__isatom(kscm, obj)) { fprintf(stderr, "int isn't atom\n"); exit(-1); } kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TINT32); kscm__fwrite_int(kscm, f, kscm__ivalue(kscm, obj)); } else if (kscm__issymbol(kscm, obj)) { if (kscm__isatom(kscm, obj)) { fprintf(stderr, "symbol is atom\n"); exit(-1); } kscm__fwrite_byte(kscm, f, kscm__issyntax(kscm, obj) ? KSCM_PERSIST_TSYNTAX : KSCM_PERSIST_TSYMBOL); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__car(kscm, obj))); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__cdr(kscm, obj))); } else if (kscm__isstring(kscm, obj)) { if (!kscm__isatom(kscm, obj)) { fprintf(stderr, "string isn't atom\n"); exit(-1); } kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TSTRING); kscm__fwrite_int(kscm, f, obj->_object._string._keynum); kscm__fwrite_str(kscm, f, kscm__strvalue(kscm, obj)); } else if (kscm__ispair(kscm, obj)) { if (kscm__isatom(kscm, obj)) { fprintf(stderr, "pair is atom\n"); exit(-1); } kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TPAIR); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__car(kscm, obj))); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__cdr(kscm, obj))); } else if (kscm__isproc(kscm, obj)) { if (!kscm__isatom(kscm, obj)) { fprintf(stderr, "proc isn't atom\n"); exit(-1); } kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TPROC); kscm__fwrite_int(kscm, f, kscm__ivalue(kscm, obj)); } else if (kscm__isclosure(kscm, obj)) { if (kscm__isatom(kscm, obj)) { fprintf(stderr, "closure is atom\n"); exit(-1); } kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TCLOSURE); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__car(kscm, obj))); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__cdr(kscm, obj))); } else if (kscm__iscontinuation(kscm, obj)) { if (kscm__isatom(kscm, obj)) { fprintf(stderr, "closure is atom\n"); exit(-1); } kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TCONTINUATION); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__car(kscm, obj))); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__cdr(kscm, obj))); } #ifdef KSCM_CONFIG_USE_STRUCTS else if (kscm__isabstraction(kscm, obj)) { if (kscm__isatom(kscm, obj)) { fprintf(stderr, "abstraction is atom\n"); exit(-1); } kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TABSTRACTION); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__car(kscm, obj))); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__cdr(kscm, obj))); } else if (kscm__isbuffer(kscm, obj)) { if (!kscm__isatom(kscm, obj)) { fprintf(stderr, "buffer isn't atom\n"); exit(-1); } kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TBUFFER); kscm__fwrite_strl(kscm, f, (const char*)(obj->_object._buffer._data), obj->_object._buffer._length); } #endif #ifdef KSCM_CONFIG_USE_FLOATS else if (kscm__isfloat64(kscm, obj)) { double tmp = obj->_object._float64._dvalue; char* bytes = (char*)(void*)(&tmp) /*obj->_object._float64._dvalue*/; kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TFLOAT64); // NOTE: This assumes floating-point endian is the same on all platforms kscm__fwrite_byte(kscm, f, bytes[0]); kscm__fwrite_byte(kscm, f, bytes[1]); kscm__fwrite_byte(kscm, f, bytes[2]); kscm__fwrite_byte(kscm, f, bytes[3]); kscm__fwrite_byte(kscm, f, bytes[4]); kscm__fwrite_byte(kscm, f, bytes[5]); kscm__fwrite_byte(kscm, f, bytes[6]); kscm__fwrite_byte(kscm, f, bytes[7]); } #endif #ifdef KSCM_CONFIG_USE_OBJECTS else if (kscm__isobjx(kscm, obj)) { if (kscm__isatom(kscm, obj)) { fprintf(stderr, "object is atom\n"); exit(-1); } kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TOBJX); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, obj->_object._objx._type)); kscm__fwrite_int(kscm, f, obj->_object._objx._count); int i; for (i = 0; i < obj->_object._objx._count; i++) { kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, obj->_object._objx._elements[i])); } } #endif else { fprintf(stderr, "Object at %d:%d is non-free but unknown type: %d\n", s, i, obj->_flag); return -1; // Not saved } } } } kscm__fwrite_int(kscm, f, 0); // Zero address to indicate end of objects kscm__fwrite_int(kscm, f, 0); // Additional zero to indicate no additional data (may be extended in future versions) fclose(f); fprintf(stderr, "\n"); return 0; // Saved } int kscm__fread_byte(kscm_t* kscm, FILE* f, char* result) { int r = fgetc(f); *result = r; return 1; } int kscm__fread_int(kscm_t* kscm, FILE* f, int* result) { *result = 0; *result |= (fgetc(f) & 0xff); *result |= (fgetc(f) & 0xff) << 8; *result |= (fgetc(f) & 0xff) << 16; *result |= (fgetc(f) & 0xff) << 24; return 4; } int kscm__fread_str(kscm_t* kscm, FILE* f, const char** result) { int len; if (kscm__fread_int(kscm, f, &len) != 4) { *result = NULL; return 0; } //fprintf(stderr, "Got length %d\n", len); if (len > 1000) { *result = NULL; return 0; } *result = (const char*) calloc(len + 1, 1); if (*result == NULL) { return 0; } int i; for (i = 0; i < len; i++) { ((* (char**)result)[i]) = (char)fgetc(f); } return len; } kscm_object_t kscm_get_object_address(kscm_t* kscm, int persistent_address) { if (persistent_address == 0) { return kscm->NIL; } else if (persistent_address == 1) { return kscm->F; } else if (persistent_address == 2) { return kscm->T; } int idx = persistent_address % KSCM_CONFIG_CELL_SEGSIZE; int segnum = persistent_address / KSCM_CONFIG_CELL_SEGSIZE; if (segnum < 1) { return NULL; } segnum--; if (segnum >= KSCM_CONFIG_CELL_NSEGMENT) { return NULL; } while (segnum > kscm->last_cell_seg) { kscm->last_cell_seg++; kscm->cell_seg[kscm->last_cell_seg] = (kscm_object_t) calloc(KSCM_CONFIG_CELL_SEGSIZE, sizeof(struct kscm_cell)); } return kscm->cell_seg[segnum] + idx; //&kscm->cell_seg[segnum][idx]; } int kscm_resume_state(kscm_t* kscm, const char* filename, const char* opts) { if (filename == NULL || strlen(filename) < 1) { fprintf(stderr, "Filename expected\n"); return -1; } FILE* f = fopen(filename, "rb"); if (f == NULL) { fprintf(stderr, "Failed to open '%s' for reading\n", filename); return -1; // Not saved } fprintf(stderr, "Reading state from '%s' opts '%s'...\n", filename, opts); const char* tmpstr; int tmpint; kscm__fread_str(kscm, f, &tmpstr); if (tmpstr == NULL || strcmp(tmpstr, KSCM_CONFIG_PERSIST_MAGIC) != 0) { fprintf(stderr, "Failed to read '%s': Bad magic string\n", filename); free((void*)tmpstr); return -1; } free((void*)tmpstr); kscm__fread_int(kscm, f, &tmpint); if (tmpint != KSCM_CONFIG_PERSIST_VERSION) { fprintf(stderr, "Failed to read '%s': Bad version number, expected %d but got %d\n", filename, KSCM_CONFIG_PERSIST_VERSION, tmpint); return -1; } kscm__fread_int(kscm, f, &tmpint); if (tmpint != 4) { fprintf(stderr, "Failed to read '%s': Bad format options, expected 4 but got %d\n", filename, tmpint); return -1; } kscm->_stateformat = tmpint; kscm__fread_int(kscm, f, &tmpint); if (tmpint != 0) { fprintf(stderr, "Failed to read '%s': Bad NIL index, expected %d but got %d\n", filename, 0, tmpint); return -1; } kscm__fread_int(kscm, f, &tmpint); if (tmpint != 1) { fprintf(stderr, "Failed to read '%s': Bad F index, expected %d but got %d\n", filename, 1, tmpint); return -1; } kscm__fread_int(kscm, f, &tmpint); if (tmpint != 2) { fprintf(stderr, "Failed to read '%s': Bad T index, expected %d but got %d\n", filename, 2, tmpint); return -1; } kscm__fread_int(kscm, f, &tmpint); kscm->oblist = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->global_env = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->LAMBDA = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->QUOTE = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->QQUOTE = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->UNQUOTE = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->UNQUOTESP = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); if (tmpint != 1) { fprintf(stderr, "Failed to read '%s': Bad number of threads, this VM only supports 1 thread but got %d\n", filename, tmpint); return -1; } /* kscm__fwrite_int(kscm, f, 1); kscm__fwrite_int(kscm, f, kscm->_threadstate); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadname)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadopts)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadobject)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->args)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->envir)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->code)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->dump)); kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->value)); kscm__fwrite_int(kscm, f, kscm->_operator); */ kscm__fread_int(kscm, f, &tmpint); kscm->_threadstate = tmpint; kscm__fread_int(kscm, f, &tmpint); kscm->_threadname = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->_threadopts = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->_threadobject = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->args = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->envir = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->code = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->dump = kscm_get_object_address(kscm, tmpint); /* At least for the main thread, the value/operator options are discarded. */ kscm__fread_int(kscm, f, &tmpint); kscm__fread_int(kscm, f, &tmpint); kscm->value = kscm->NIL; //kscm_get_object_address(kscm, tmpint); kscm->_operator = 0; //fprintf(stderr, "Persistent addresses: ->T=%d ->F=%d ->NIL=%d\n", kscm_get_persistent_address(kscm, kscm->T), kscm_get_persistent_address(kscm, kscm->F), kscm_get_persistent_address(kscm, kscm->NIL)); //fprintf(stderr, "Persistent addresses: ->args=%d ->envir=%d ->code=%d ->dump=%d\n", kscm_get_persistent_address(kscm, kscm->args), kscm_get_persistent_address(kscm, kscm->envir), kscm_get_persistent_address(kscm, kscm->code), kscm_get_persistent_address(kscm, kscm->dump)); /* Clear all of the cell memory. Any new blocks that get automatically allocated will be cleared upon allocation. */ int i; for (i = 0; i <= kscm->last_cell_seg; i++) { memset(kscm->cell_seg[i], 0, sizeof(struct kscm_cell) * KSCM_CONFIG_CELL_SEGSIZE); } int objid; do { if (kscm__fread_int(kscm, f, &objid) != 4) { fprintf(stderr, "WTFERR1\n"); exit(-1); return -1; } if (objid == 0) break; kscm_object_t obj = kscm_get_object_address(kscm, objid); if (obj == NULL) { fprintf(stderr, "WTFERR2\n"); exit(-1); return -1; } char typ = 0; if (kscm__fread_byte(kscm, f, &typ) != 1) { fprintf(stderr, "WTFERR3\n"); exit(-1); return -1; } fprintf(stderr, "Got type %d\n", typ); const char* tmpstr; switch (typ) { case KSCM_PERSIST_TINT32: obj->_flag = KSCM_T_NUMBER | KSCM_T_ATOM; kscm__fread_int(kscm, f, &tmpint); obj->_object._number._ivalue = tmpint; break; case KSCM_PERSIST_TSTRING: obj->_flag = KSCM_T_STRING | KSCM_T_ATOM; kscm__fread_int(kscm, f, &tmpint); obj->_object._string._keynum = tmpint; tmpint = kscm__fread_str(kscm, f, &tmpstr); if (tmpint < 0) { fprintf(stderr, "WTFERR4\n"); exit(-1); return -1; } //fprintf(stderr, "Got str len %d '%s'\n", tmpint, tmpstr); #ifdef __WIN32 obj->_object._string._svalue = _strdup(tmpstr);//kscm__store_string(kscm, tmpstr); #else obj->_object._string._svalue = strdup(tmpstr);//kscm__store_string(kscm, tmpstr); #endif free((void*)tmpstr); break; case KSCM_PERSIST_TSYMBOL: obj->_flag = KSCM_T_SYMBOL; kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._car = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint); break; case KSCM_PERSIST_TPAIR: obj->_flag = KSCM_T_PAIR; kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._car = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint); break; case KSCM_PERSIST_TPROC: obj->_flag = KSCM_T_PROC | KSCM_T_ATOM; kscm__fread_int(kscm, f, &tmpint); obj->_object._number._ivalue = tmpint; break; case KSCM_PERSIST_TCLOSURE: obj->_flag = KSCM_T_CLOSURE; kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._car = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint); break; case KSCM_PERSIST_TSYNTAX: obj->_flag = KSCM_T_SYMBOL | KSCM_T_SYNTAX; kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._car = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint); break; case KSCM_PERSIST_TCONTINUATION: obj->_flag = KSCM_T_CONTINUATION; kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._car = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint); break; #ifdef KSCM_CONFIG_USE_STRUCTS case KSCM_PERSIST_TABSTRACTION: obj->_flag = KSCM_T_ABSTRACTION; kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._car = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint); break; case KSCM_PERSIST_TBUFFER: obj->_flag = KSCM_T_BUFFER | KSCM_T_ATOM; tmpint = kscm__fread_str(kscm, f, &tmpstr); obj->_object._buffer._length = tmpint; if (tmpint < 0) { fprintf(stderr, "WTFERR4\n"); exit(-1); return -1; } //fprintf(stderr, "Got str len %d '%s'\n", tmpint, tmpstr); obj->_object._buffer._data = (unsigned char*) tmpstr; //kscm__store_string(kscm, tmpstr); //free((void*)tmpstr); break; #endif #ifdef KSCM_CONFIG_USE_FLOATS case KSCM_PERSIST_TFLOAT64: { obj->_flag = KSCM_T_FLOAT64 | KSCM_T_ATOM; double tmp; char* bytes = (char*)(void*)&tmp; //obj->_object._float64._dvalue; kscm__fread_byte(kscm, f, &bytes[0]); kscm__fread_byte(kscm, f, &bytes[1]); kscm__fread_byte(kscm, f, &bytes[2]); kscm__fread_byte(kscm, f, &bytes[3]); kscm__fread_byte(kscm, f, &bytes[4]); kscm__fread_byte(kscm, f, &bytes[5]); kscm__fread_byte(kscm, f, &bytes[6]); kscm__fread_byte(kscm, f, &bytes[7]); obj->_object._float64._dvalue = tmp; } break; #endif #ifdef KSCM_CONFIG_USE_STRUCTS case KSCM_PERSIST_TOBJX: obj->_flag = KSCM_T_OBJX; kscm__fread_int(kscm, f, &tmpint); obj->_object._objx._type = kscm_get_object_address(kscm, tmpint); kscm__fread_int(kscm, f, &tmpint); obj->_object._objx._count = tmpint; obj->_object._objx._elements = (kscm_object_t*) calloc(sizeof(kscm_object_t), obj->_object._objx._count); // TODO Check non-null (ideally check size is sane before attempting to allocate/fill) for (i = 0; i < obj->_object._objx._count; i++) { kscm__fread_int(kscm, f, &tmpint); obj->_object._objx._elements[i] = kscm_get_object_address(kscm, tmpint); } break; #endif default: fprintf(stderr, "Unknown object type #%d\n", typ); exit(1); if (1) return 0; } } while (objid != 0); kscm->free_cell = kscm->NIL; kscm->fcells = 0; return 0; // Resumed } /* From ifdef KSCM_CONFIG_USE_PERSIST */ #endif kscm_object_t kscm__opexe_7(kscm_t* kscm, register short op) { register kscm_object_t x, y, z; char* str1; char* str2; char* str3; register long v; static long w; switch (op) { case KSCM_OP_STRCAT: x = kscm__car(kscm, kscm->args); y = kscm__cadr(kscm, kscm->args); if (!kscm__isstring(kscm, x) || !kscm__isstring(kscm, y)) { kscm__s_retbool(kscm, 0); } str1 = kscm__strvalue(kscm, x); str2 = kscm__strvalue(kscm, y); str3 = (char*)calloc(strlen(str1) + strlen(str2) + 1, 1); if (str3 == NULL) { kscm__s_retbool(kscm, 0); } strcat(str3, str1); strcat(str3, str2); z = kscm__mk_string(kscm, str3); free(str3); kscm__s_return(kscm, z); case KSCM_OP_STRLEN: x = kscm__car(kscm, kscm->args); if (!kscm__isstring(kscm, x)) { kscm__s_retbool(kscm, 0); } str1 = kscm__strvalue(kscm, x); kscm__s_return(kscm, kscm__mk_number(kscm, strlen(str1))); case KSCM_OP_STRGET: x = kscm__car(kscm, kscm->args); y = kscm__cadr(kscm, kscm->args); if (!kscm__isstring(kscm, x) || !kscm__isnumber(kscm, y)) { kscm__s_retbool(kscm, 0); } str1 = kscm__strvalue(kscm, x); v = kscm__ivalue(kscm, y); if (v < 0 || v >= strlen(str1)) { kscm__s_retbool(kscm, 0); } kscm__s_return(kscm, kscm__mk_number(kscm, ((int)(str1[v])) & 0xFF)); #ifdef KSCM_CONFIG_USE_PERSIST case KSCM_OP_SAVE_STATE: x = kscm__car(kscm, kscm->args); y = kscm__cadr(kscm, kscm->args); str1 = kscm__strvalue(kscm, x); str2 = kscm__strvalue(kscm, y); if (kscm_save_state(kscm, str1, str2) == 0) { kscm__s_return(kscm, kscm__mk_symbol(kscm, "saved")); } else { kscm__s_retbool(kscm, 0); } case KSCM_OP_RESUME_STATE: x = kscm__car(kscm, kscm->args); y = kscm__cadr(kscm, kscm->args); str1 = kscm__strvalue(kscm, x); str2 = kscm__strvalue(kscm, y); if (kscm_resume_state(kscm, str1, str2) == 0) { kscm__s_return(kscm, kscm__mk_symbol(kscm, "resumed")); } else { kscm__s_retbool(kscm, 0); } #endif #ifdef KSCM_CONFIG_USE_STRUCTS case KSCM_OP_BUFFER: kscm__s_retbool(kscm, kscm__isbuffer(kscm, kscm__car(kscm, kscm->args))); case KSCM_OP_BUFFER_NEW: x = kscm__car(kscm, kscm->args); if (kscm__isstring(kscm, x)) { const char* strval = kscm__strvalue(kscm, x); size_t slen = strlen(strval); y = kscm__mk_buffer(kscm, slen); size_t iter; for (iter = 0; iter < slen; iter++) { y->_object._buffer._data[iter] = strval[iter]; } kscm__s_return(kscm, y); } else if (!kscm__isnumber(kscm, x)) { kscm__s_return(kscm, kscm->NIL); } kscm__s_return(kscm, kscm__mk_buffer(kscm, kscm__ivalue(kscm, x))); case KSCM_OP_BUFFER_LEN: x = kscm__car(kscm, kscm->args); if (!kscm__isbuffer(kscm, x)) { kscm__s_return(kscm, kscm->F); } kscm__s_return(kscm, kscm__mk_number(kscm, x->_object._buffer._length)); case KSCM_OP_BUFFER_GET: x = kscm__car(kscm, kscm->args); y = kscm__cadr(kscm, kscm->args); if (!kscm__isbuffer(kscm, x) || !kscm__isnumber(kscm, y)) { kscm__s_return(kscm, kscm->F); } v = kscm__ivalue(kscm, y); if (v < 0 || v >= x->_object._buffer._length) { kscm__s_return(kscm, kscm->F); } kscm__s_return(kscm, kscm__mk_number(kscm, ((long)(x->_object._buffer._data[v])) & 0xFF)); case KSCM_OP_BUFFER_SET: x = kscm__car(kscm, kscm->args); y = kscm__cadr(kscm, kscm->args); z = kscm__caddr(kscm, kscm->args); if (!kscm__isbuffer(kscm, x) || !kscm__isnumber(kscm, y) || !kscm__isnumber(kscm, z)) { kscm__s_return(kscm, kscm->F); } v = kscm__ivalue(kscm, y); if (v < 0 || v >= x->_object._buffer._length) { kscm__s_return(kscm, kscm->F); } x->_object._buffer._data[v] = (unsigned char)kscm__ivalue(kscm, z); kscm__s_return(kscm, kscm->T); case KSCM_OP_BUFFER_LOAD: kscm__s_return(kscm, kscm__mk_string(kscm, "TODO")); case KSCM_OP_BUFFER_SAVE: kscm__s_return(kscm, kscm__mk_string(kscm, "TODO")); case KSCM_OP_ABSTRACTION: kscm__s_retbool(kscm, kscm__isabstraction(kscm, kscm__car(kscm, kscm->args))); case KSCM_OP_ABSTRACTION_NEW: x = kscm__car(kscm, kscm->args); y = kscm__cadr(kscm, kscm->args); kscm__s_return(kscm, kscm__mk_abstraction(kscm, x, y)); case KSCM_OP_ABSTRACTION_TYPE: x = kscm__car(kscm, kscm->args); #ifdef KSCM_CONFIG_USE_OBJECTS if (kscm__isobjx(kscm, x)) { kscm__s_return(kscm, x->_object._objx._type); } #endif if (!kscm__isabstraction(kscm, x)) { kscm__s_retbool(kscm, 0); } kscm__s_return(kscm, kscm__car(kscm, x)); case KSCM_OP_ABSTRACTION_VALUE: x = kscm__car(kscm, kscm->args); if (!kscm__isabstraction(kscm, x)) { kscm__s_retbool(kscm, 0); } kscm__s_return(kscm, kscm__cdr(kscm, x)); #endif #ifdef KSCM_CONFIG_USE_OBJECTS case KSCM_OP_OBJECT: kscm__s_retbool(kscm, kscm__isobjx(kscm, kscm__car(kscm, kscm->args))); case KSCM_OP_OBJECT_NEW: x = kscm__car(kscm, kscm->args); y = kscm__cadr(kscm, kscm->args); if (!kscm__isnumber(kscm, y)) { kscm__s_return(kscm, kscm->F); } kscm__s_return(kscm, kscm__mk_objx(kscm, x, kscm__ivalue(kscm, y))); case KSCM_OP_OBJECT_LEN: x = kscm__car(kscm, kscm->args); if (!kscm__isobjx(kscm, x)) { kscm__s_return(kscm, kscm->F); } kscm__s_return(kscm, kscm__mk_number(kscm, x->_object._objx._count)); case KSCM_OP_OBJECT_GET: x = kscm__car(kscm, kscm->args); y = kscm__cadr(kscm, kscm->args); if (!kscm__isobjx(kscm, x) || !kscm__isnumber(kscm, y)) { kscm__s_return(kscm, kscm->F); } v = kscm__ivalue(kscm, y); if (v < 0 || v >= x->_object._objx._count) { kscm__s_return(kscm, kscm->F); } kscm__s_return(kscm, x->_object._objx._elements[v]); case KSCM_OP_OBJECT_SET: x = kscm__car(kscm, kscm->args); y = kscm__cadr(kscm, kscm->args); z = kscm__caddr(kscm, kscm->args); if (!kscm__isobjx(kscm, x) || !kscm__isnumber(kscm, y)) { kscm__s_return(kscm, kscm->F); } v = kscm__ivalue(kscm, y); if (v < 0 || v >= x->_object._objx._count) { kscm__s_return(kscm, kscm->F); } x->_object._objx._elements[v] = z; kscm__s_return(kscm, kscm->T); case KSCM_OP_OBJECT_RETYPE: x = kscm__car(kscm, kscm->args); y = kscm__cadr(kscm, kscm->args); if (!kscm__isobjx(kscm, x)) { kscm__s_return(kscm, kscm->F); } x->_object._objx._type = y; kscm__s_return(kscm, kscm->T); #endif case KSCM_OP_SYMBOL_TO_STRING: #ifdef KSCM_CONFIG_USE_STRUCTS /* We handle buffer->string in the same function if structs are enabled. */ if (kscm__isbuffer(kscm, kscm__car(kscm, kscm->args))) { x = kscm__car(kscm, kscm->args); char* tmp_buffer = (char*) calloc(x->_object._buffer._length, 1); if (tmp_buffer == NULL) { kscm__s_return(kscm, kscm->NIL); } size_t iter; for (iter = 0; iter < x->_object._buffer._length; iter++) { tmp_buffer[iter] = x->_object._buffer._data[iter]; } /* Note: All the messaround above was only to keep the string-creation API consistent. * It would be easy to optimise the buffer->string case by creating the string object manually. */ y = kscm__mk_string(kscm, tmp_buffer); free(tmp_buffer); kscm__s_return(kscm, y); } #endif if (kscm__issymbol(kscm, kscm__car(kscm, kscm->args))) { x = kscm__caar(kscm, kscm->args); kscm__s_return(kscm, x); } else { kscm__s_return(kscm, kscm->F); } default: sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator); kscm__error_0(kscm, kscm->strbuff); } return kscm->T; /* NOTREACHED */ } kscm_object_t kscm__opexe_8(kscm_t* kscm, register short op) { register kscm_object_t x, y, z; char* str1; char* str2; char* str3; register long v; static long w; #ifdef KSCM_CONFIG_USE_CONSOLE struct winsize ws; int fd; #endif switch (op) { #ifdef KSCM_CONFIG_USE_CONSOLE case KSCM_OP_CONSOLE_MODE: x = kscm__mk_string(kscm, ttyname(STDIN_FILENO)); kscm__s_return(kscm, x); case KSCM_OP_CONSOLE_WIDTH: case KSCM_OP_CONSOLE_HEIGHT: str1 = ttyname(STDIN_FILENO); // NOTE: "/dev/tty" may work if this isn't available! fd = open(str1, O_RDWR); if (fd < 0) { kscm__error_0(kscm, "Failed to open console device"); } /* Get window size of terminal. */ if (ioctl(fd, TIOCGWINSZ, &ws) < 0) { kscm__error_0(kscm, "Failed to get console info"); } close(fd); if (op == KSCM_OP_CONSOLE_WIDTH) { kscm__s_return(kscm, kscm__mk_number(kscm, ws.ws_row)); } else { kscm__s_return(kscm, kscm__mk_number(kscm, ws.ws_row)); } #else case KSCM_OP_CONSOLE_MODE: kscm__s_return(kscm, kscm->F); #endif /* kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_MODE); kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_NEXT); kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_POLL); kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_WIDTH); kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_HEIGHT); */ default: sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator); kscm__error_0(kscm, kscm->strbuff); } return kscm->T; /* NOTREACHED */ } typedef kscm_object_t(*kscm_dispatchf_t)(kscm_t* kscm, register short op); kscm_dispatchf_t kscm__shared_dispatch_table[256]; void kscm__eval_set(kscm_t* kscm, kscm_dispatchf_t func, int tag) { kscm__shared_dispatch_table[tag] = func; } void kscm__eval_setup(kscm_t* kscm) { if (kscm__shared_dispatch_table[KSCM_OP_LOAD] == &kscm__opexe_0) { return; } kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LOAD); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_T0LVL); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_T1LVL); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_READ); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_VALUEPRINT); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_EVAL); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_E0ARGS); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_E1ARGS); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_APPLY); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_DOMACRO); // kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LAMBDA); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_QUOTE); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_DEF0); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_DEF1); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_BEGIN); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_IF0); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_IF1); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_SET0); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_SET1); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET0); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET1); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET2); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET0AST); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET1AST); kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET2AST); // kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_LET0REC); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_LET1REC); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_LET2REC); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_COND0); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_COND1); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_DELAY); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_AND0); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_AND1); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_OR0); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_OR1); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_C0STREAM); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_C1STREAM); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_0MACRO); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_1MACRO); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_CASE0); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_CASE1); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_CASE2); // kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_PEVAL); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_PAPPLY); kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_CONTINUATION); // kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_ADD); kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_SUB); kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_MUL); kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_DIV); kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_REM); kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_CAR); kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_CDR); kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_CONS); kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_SETCAR); kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_SETCDR); // kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_NOT); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_BOOL); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_NULL); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_ZEROP); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_POSP); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_NEGP); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_NEQ); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_LESS); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_GRE); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_LEQ); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_GEQ); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_SYMBOL); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_NUMBER); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_STRING); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_PROC); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_PAIR); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_EQ); kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_EQV); // kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_FORCE); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_WRITE); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_DISPLAY); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_NEWLINE); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_ERR0); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_ERR1); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_REVERSE); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_APPEND); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_PUT); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_GET); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_QUIT); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_GC); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_GCVERB); kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_NEWSEGMENT); // kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDSEXPR); kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDLIST); kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDDOT); kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDQUOTE); kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDQQUOTE); kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDUNQUOTE); kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDUQTSP); kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_P0LIST); kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_P1LIST); // kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_LIST_LENGTH); kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_ASSQ); kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_PRINT_WIDTH); kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_P0_WIDTH); kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_P1_WIDTH); kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_GET_CLOSURE); kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_CLOSUREP); //#ifdef KSCM_CONFIG_USE_MACRO kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_MACROP); //#endif Removed ifdef to keep ordering consistent. -Zak. kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_STRCAT); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_STRLEN); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_STRGET); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_SAVE_STATE); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_RESUME_STATE); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_NEW); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_LEN); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_GET); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_SET); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_ABSTRACTION); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_ABSTRACTION_NEW); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_ABSTRACTION_TYPE); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_ABSTRACTION_VALUE); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT_NEW); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT_LEN); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT_GET); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT_SET); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT_RETYPE); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_SYMBOL_TO_STRING); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_LOAD); kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_SAVE); kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_MODE); kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_NEXT); kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_POLL); kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_WIDTH); kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_HEIGHT); } /* These and the commented-out parts of kscm__eval_cycle can be re-enabled if you need to make sure the interpreter is running. int fixme_reccheck = 0; int fixme_ops = 0; */ /* kernel of this intepreter */ kscm_object_t kscm__eval_cycle(kscm_t* kscm, register short op) { kscm__eval_setup(kscm); /*fixme_reccheck++; if (fixme_reccheck > 1) { fprintf(stderr, "Warning reccheck=%d\n", fixme_reccheck); }*/ kscm->_operator = op; for (;;) { kscm_object_t(*func)(kscm_t* kscm, register short op) = kscm__shared_dispatch_table[kscm->_operator]; if (func == NULL) { fprintf(stderr, "Error! Opcode %d leads to NULL!\n", kscm->_operator); exit(-1); } if (/*(*kscm__shared_dispatch_table[kscm->_operator])*/ func(kscm, kscm->_operator) == kscm->NIL) { //fixme_reccheck--; return kscm->NIL; } /*if ((fixme_ops % 1000) == 0) { fprintf(stderr, "Just did op %d\n", fixme_ops); } fixme_ops++;*/ } } /* ========== Initialization of internal keywords ========== */ void kscm__mk_syntax(kscm_t* kscm, unsigned short op, const char *name) { kscm_object_t x; x = kscm__cons(kscm, kscm__mk_string(kscm, name), kscm->NIL); kscm__type(kscm, x) = (KSCM_T_SYNTAX | KSCM_T_SYMBOL); kscm__syntaxnum(kscm, x) = op; kscm->oblist = kscm__cons(kscm, x, kscm->oblist); } void kscm__mk_proc(kscm_t* kscm, unsigned short op, const char *name) { kscm_object_t x, y; x = kscm__mk_symbol(kscm, name); y = kscm__get_cell(kscm, kscm->NIL, kscm->NIL); kscm__type(kscm, y) = (KSCM_T_PROC | KSCM_T_ATOM); kscm__ivalue(kscm, y) = (long)op; kscm__car(kscm, kscm->global_env) = kscm__cons(kscm, kscm__cons(kscm, x, y), kscm__car(kscm, kscm->global_env)); } void kscm__init_vars_global(kscm_t* kscm) { kscm_object_t x; /* init input/output file */ kscm->inputs[kscm->inputtop] = stdin; kscm->outfp = stdout; /* init kscm->NIL */ kscm__type(kscm, kscm->NIL) = (KSCM_T_ATOM | KSCM_MARK); kscm__car(kscm, kscm->NIL) = kscm__cdr(kscm, kscm->NIL) = kscm->NIL; /* init T */ kscm__type(kscm, kscm->T) = (KSCM_T_ATOM | KSCM_MARK); kscm__car(kscm, kscm->T) = kscm__cdr(kscm, kscm->T) = kscm->T; /* init F */ kscm__type(kscm, kscm->F) = (KSCM_T_ATOM | KSCM_MARK); kscm__car(kscm, kscm->F) = kscm__cdr(kscm, kscm->F) = kscm->F; /* init global_env */ kscm->global_env = kscm__cons(kscm, kscm->NIL, kscm->NIL); /* init else */ x = kscm__mk_symbol(kscm, "else"); kscm__car(kscm, kscm->global_env) = kscm__cons(kscm, kscm__cons(kscm, x, kscm->T), kscm__car(kscm, kscm->global_env)); } void kscm__init_syntax(kscm_t* kscm) { /* init syntax */ kscm__mk_syntax(kscm, KSCM_OP_LAMBDA, "lambda"); kscm__mk_syntax(kscm, KSCM_OP_QUOTE, "quote"); kscm__mk_syntax(kscm, KSCM_OP_DEF0, "define"); kscm__mk_syntax(kscm, KSCM_OP_IF0, "if"); kscm__mk_syntax(kscm, KSCM_OP_BEGIN, "begin"); kscm__mk_syntax(kscm, KSCM_OP_SET0, "set!"); kscm__mk_syntax(kscm, KSCM_OP_LET0, "let"); kscm__mk_syntax(kscm, KSCM_OP_LET0AST, "let*"); kscm__mk_syntax(kscm, KSCM_OP_LET0REC, "letrec"); kscm__mk_syntax(kscm, KSCM_OP_COND0, "cond"); kscm__mk_syntax(kscm, KSCM_OP_DELAY, "delay"); kscm__mk_syntax(kscm, KSCM_OP_AND0, "and"); kscm__mk_syntax(kscm, KSCM_OP_OR0, "or"); kscm__mk_syntax(kscm, KSCM_OP_C0STREAM, "cons-stream"); #ifdef KSCM_CONFIG_USE_MACRO kscm__mk_syntax(kscm, KSCM_OP_0MACRO, "macro"); #endif kscm__mk_syntax(kscm, KSCM_OP_CASE0, "case"); } void kscm__init_procs(kscm_t* kscm) { /* init procedure */ kscm__mk_proc(kscm, KSCM_OP_PEVAL, "eval"); kscm__mk_proc(kscm, KSCM_OP_PAPPLY, "apply"); kscm__mk_proc(kscm, KSCM_OP_CONTINUATION, "call-with-current-continuation"); kscm__mk_proc(kscm, KSCM_OP_FORCE, "force"); kscm__mk_proc(kscm, KSCM_OP_CAR, "car"); kscm__mk_proc(kscm, KSCM_OP_CDR, "cdr"); kscm__mk_proc(kscm, KSCM_OP_CONS, "cons"); kscm__mk_proc(kscm, KSCM_OP_SETCAR, "set-car!"); kscm__mk_proc(kscm, KSCM_OP_SETCDR, "set-cdr!"); kscm__mk_proc(kscm, KSCM_OP_ADD, "+"); kscm__mk_proc(kscm, KSCM_OP_SUB, "-"); kscm__mk_proc(kscm, KSCM_OP_MUL, "*"); kscm__mk_proc(kscm, KSCM_OP_DIV, "/"); kscm__mk_proc(kscm, KSCM_OP_REM, "remainder"); kscm__mk_proc(kscm, KSCM_OP_NOT, "not"); kscm__mk_proc(kscm, KSCM_OP_BOOL, "boolean?"); kscm__mk_proc(kscm, KSCM_OP_SYMBOL, "symbol?"); kscm__mk_proc(kscm, KSCM_OP_NUMBER, "number?"); kscm__mk_proc(kscm, KSCM_OP_STRING, "string?"); kscm__mk_proc(kscm, KSCM_OP_PROC, "procedure?"); kscm__mk_proc(kscm, KSCM_OP_PAIR, "pair?"); kscm__mk_proc(kscm, KSCM_OP_EQV, "eqv?"); kscm__mk_proc(kscm, KSCM_OP_EQ, "eq?"); kscm__mk_proc(kscm, KSCM_OP_NULL, "null?"); kscm__mk_proc(kscm, KSCM_OP_ZEROP, "zero?"); kscm__mk_proc(kscm, KSCM_OP_POSP, "positive?"); kscm__mk_proc(kscm, KSCM_OP_NEGP, "negative?"); kscm__mk_proc(kscm, KSCM_OP_NEQ, "="); kscm__mk_proc(kscm, KSCM_OP_LESS, "<"); kscm__mk_proc(kscm, KSCM_OP_GRE, ">"); kscm__mk_proc(kscm, KSCM_OP_LEQ, "<="); kscm__mk_proc(kscm, KSCM_OP_GEQ, ">="); kscm__mk_proc(kscm, KSCM_OP_READ, "read"); kscm__mk_proc(kscm, KSCM_OP_WRITE, "write"); kscm__mk_proc(kscm, KSCM_OP_DISPLAY, "display"); kscm__mk_proc(kscm, KSCM_OP_NEWLINE, "newline"); kscm__mk_proc(kscm, KSCM_OP_LOAD, "load"); kscm__mk_proc(kscm, KSCM_OP_ERR0, "error"); kscm__mk_proc(kscm, KSCM_OP_REVERSE, "reverse"); kscm__mk_proc(kscm, KSCM_OP_APPEND, "append"); kscm__mk_proc(kscm, KSCM_OP_PUT, "put"); kscm__mk_proc(kscm, KSCM_OP_GET, "get"); kscm__mk_proc(kscm, KSCM_OP_GC, "gc"); kscm__mk_proc(kscm, KSCM_OP_GCVERB, "gc-verbose"); kscm__mk_proc(kscm, KSCM_OP_NEWSEGMENT, "new-segment"); kscm__mk_proc(kscm, KSCM_OP_LIST_LENGTH, "list-length"); /* a.k */ kscm__mk_proc(kscm, KSCM_OP_ASSQ, "assq"); /* a.k */ kscm__mk_proc(kscm, KSCM_OP_PRINT_WIDTH, "print-width"); /* a.k */ kscm__mk_proc(kscm, KSCM_OP_GET_CLOSURE, "get-closure-code"); /* a.k */ kscm__mk_proc(kscm, KSCM_OP_CLOSUREP, "closure?"); /* a.k */ #ifdef KSCM_CONFIG_USE_MACRO kscm__mk_proc(kscm, KSCM_OP_MACROP, "macro?"); /* a.k */ #endif kscm__mk_proc(kscm, KSCM_OP_STRCAT, "string-cat"); kscm__mk_proc(kscm, KSCM_OP_STRLEN, "string-length"); kscm__mk_proc(kscm, KSCM_OP_STRGET, "string-get"); #ifdef KSCM_CONFIG_USE_PERSIST kscm__mk_proc(kscm, KSCM_OP_SAVE_STATE, "save-state"); kscm__mk_proc(kscm, KSCM_OP_RESUME_STATE, "resume-state"); #endif #ifdef KSCM_CONFIG_USE_STRUCTS kscm__mk_proc(kscm, KSCM_OP_BUFFER, "buffer?"); kscm__mk_proc(kscm, KSCM_OP_BUFFER_NEW, "buffer-new"); kscm__mk_proc(kscm, KSCM_OP_BUFFER_LEN, "buffer-length"); kscm__mk_proc(kscm, KSCM_OP_BUFFER_GET, "buffer-get"); kscm__mk_proc(kscm, KSCM_OP_BUFFER_SET, "buffer-set!"); kscm__mk_proc(kscm, KSCM_OP_ABSTRACTION, "abstraction?"); kscm__mk_proc(kscm, KSCM_OP_ABSTRACTION_NEW, "abstraction-new"); kscm__mk_proc(kscm, KSCM_OP_ABSTRACTION_TYPE, "abstraction-type"); kscm__mk_proc(kscm, KSCM_OP_ABSTRACTION_VALUE, "abstraction-value"); kscm__mk_proc(kscm, KSCM_OP_BUFFER_LOAD, "buffer-load"); kscm__mk_proc(kscm, KSCM_OP_BUFFER_SAVE, "buffer-save"); kscm__mk_proc(kscm, KSCM_OP_CONSOLE_MODE, "console-mode"); kscm__mk_proc(kscm, KSCM_OP_CONSOLE_NEXT, "console-next"); kscm__mk_proc(kscm, KSCM_OP_CONSOLE_POLL, "console-poll"); kscm__mk_proc(kscm, KSCM_OP_CONSOLE_WIDTH, "console-width"); kscm__mk_proc(kscm, KSCM_OP_CONSOLE_HEIGHT, "console-height"); #endif #ifdef KSCM_CONFIG_USE_OBJECTS kscm__mk_proc(kscm, KSCM_OP_OBJECT, "object?"); kscm__mk_proc(kscm, KSCM_OP_OBJECT_NEW, "object-new"); kscm__mk_proc(kscm, KSCM_OP_OBJECT_LEN, "object-length"); kscm__mk_proc(kscm, KSCM_OP_OBJECT_GET, "object-get"); kscm__mk_proc(kscm, KSCM_OP_OBJECT_SET, "object-set!"); kscm__mk_proc(kscm, KSCM_OP_OBJECT_RETYPE, "object-retype!"); /* NOTE: There is no object-type function, the abstraction-type function handles all custom-typed values. */ #endif kscm__mk_proc(kscm, KSCM_OP_SYMBOL_TO_STRING, "symbol->string"); kscm__mk_proc(kscm, KSCM_OP_QUIT, "quit"); } /* initialize several globals */ void kscm__init_globals(kscm_t* kscm) { kscm__init_vars_global(kscm); kscm__init_syntax(kscm); kscm__init_procs(kscm); /* intialization of global pointers to special symbols */ kscm->LAMBDA = kscm__mk_symbol(kscm, "lambda"); kscm->QUOTE = kscm__mk_symbol(kscm, "quote"); #ifdef KSCM_CONFIG_USE_QQUOTE kscm->QQUOTE = kscm__mk_symbol(kscm, "quasiquote"); kscm->UNQUOTE = kscm__mk_symbol(kscm, "unquote"); kscm->UNQUOTESP = kscm__mk_symbol(kscm, "unquote-splicing"); #endif } /* ========== Error ========== */ void kscm__fatal_error(kscm_t* kscm, const char *fmt, const char *a, const char *b, const char *c) { fprintf(stderr, "Fatal error: "); fprintf(stderr, fmt, a, b, c); fprintf(stderr, "\n"); exit(1); } #ifdef KSCM_CONFIG_USE_SETJMP void kscm__error(kscm_t* kscm, const char *fmt, const char *a, const char *b, const char *c) { fprintf(stderr, "Error: "); fprintf(stderr, fmt, a, b, c); fprintf(stderr, "\n"); kscm__resetinput(kscm); longjmp(kscm->error_jmp, KSCM_OP_T0LVL); } #endif /* ========== Main ========== */ #ifdef CMDLINE int main(int argc, char **argv) #else int main() #endif { short i; short op = (short)KSCM_OP_LOAD; #ifdef CMDLINE for (i = 1; i < argc; i++) { if (strcmp(argv[i], "-e") == 0) { all_errors_fatal = 1; } else if (strcmp(argv[i], "-q") == 0) { quiet = 1; } } #endif kscm_t* kscm = (kscm_t*) calloc(1, sizeof(kscm_t)); kscm->cell_seg = calloc(KSCM_CONFIG_CELL_NSEGMENT, sizeof(kscm_object_t)); kscm->gcstate = calloc(4000, sizeof(kscm_gcstate_t)); kscm->gcstate_max = 4000; if (!kscm->quiet) printf(KSCM_CONFIG_BANNER); kscm__init_scheme(kscm); kscm->args = kscm__cons(kscm, kscm__mk_string(kscm, KSCM_CONFIG_INITFILE), kscm->NIL); #ifdef KSCM_CONFIG_USE_SETJMP op = setjmp(kscm->error_jmp); #endif kscm__eval_cycle(kscm, op); exit(0); } #ifdef KSCM_PLUSPLUS } #endif