├── .gitignore ├── Makefile ├── README ├── init.scm ├── miniscm.c ├── nextleaf.scm └── tools.scm /.gitignore: -------------------------------------------------------------------------------- 1 | miniscm 2 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for miniscm 2 | # 3 | # This defaults to using ANSI C on 4.3 BSD-flavoured UNIX (which is 4 | # compatible with many modern Unices, including Linux). You may select a 5 | # different flavour of UNIX, or a pre-ANSI version of C, by telling make 6 | # to override the CC and/or CFLAGS variables. 7 | # Please see source and/or README for system definition #define's. 8 | # 9 | # Examples: 10 | # CFLAGS = -g -DSYSV -traditional -traditional-cpp -Wid-clash-8 11 | # CFLAGS = -O -DSYSV 12 | 13 | CC ?= gcc 14 | CFLAGS ?= -O -ansi -pedantic -DBSD -DCMDLINE 15 | 16 | all : miniscm 17 | 18 | miniscm : miniscm.c Makefile 19 | $(CC) $(CFLAGS) -o miniscm miniscm.c 20 | 21 | clean : 22 | rm -f core *.o miniscm *~ 23 | 24 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is Cat's Eye Technologies' fork of the original Mini-Scheme 2 | implementation, miniscm, by Atsushi Moriwaki. The original README can 3 | be found below, following the first line of equals signs in this file. 4 | 5 | My understanding is that Akira KIDA is no longer actively maintaining 6 | this project, and that the Mini-Scheme language and miniscm reference 7 | implementation effectively have no maintainer. It is not my objective 8 | to become the new maintainer of the language or implementation; rather, 9 | it is simply to provide a modernized and generally backwards-compatible 10 | source base for miniscm. 11 | 12 | This code was forked from version 0.85k4. The current version of this 13 | fork is 0.85ce1. (I elected to use "ce" for "Cat's Eye" because "p" for 14 | "Pressey" is too easily confused with "patchlevel".) 15 | 16 | Some improvements that have been made: 17 | 18 | - modernized Makefile (defaults to 4.3 BSD, which works for Linux) 19 | - removed compiler warnings (under 4.3 BSD) 20 | - made compilable under AmigaOS 1.3 with DICE C 21 | - added -q command line option to suppress all non-explicit output 22 | (this includes the prompt; if you want output, use (display)) 23 | - added -e command line option to cause all errors to be treated 24 | as fatal errors (exit interpreter immediately with error code 1) 25 | 26 | Some further improvements I might consider: 27 | 28 | - add -i command line option to specify the location of init.scm 29 | - add -l command line option to disable abbreviated quote output 30 | - allow source file(s) to be specified on command line 31 | 32 | If you are interested in a more developed and actively maintained 33 | Scheme implementation which started as a fork of miniscm, check out 34 | the BSD-licensed TinyScheme: http://tinyscheme.sourceforge.net/ 35 | 36 | There is also another fork of miniscm on Sourceforge with the name 37 | "minischeme", although at 2 megabytes, I'm not sure it deserves the 38 | appelation "mini" any more: http://sourceforge.net/projects/minischeme/ 39 | 40 | -Chris 41 | 42 | ===================================================================== 43 | 44 | ---------- Mini-Scheme Interpreter Version 0.85 ---------- 45 | 46 | coded by Atsushi Moriwaki (11/5/1989) 47 | 48 | E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp 49 | MIX : riemann 50 | NIFTY : PBB01074 51 | (Note that these addresses are now obsolete, see below) 52 | 53 | ===================================================================== 54 | 55 | Revised by Akira KIDA 56 | 57 | Version 0.85k4 (17 May 1994) 58 | Version 0.85k3 (30 Nov 1989) 59 | Version 0.85k2 (28 Nov 1989) 60 | Version 0.85k1 (14 Nov 1989) 61 | 62 | Mini-Scheme is now maintained by Akira KIDA. 63 | 64 | E-Mail : SDI00379@niftyserve.or.jp 65 | 66 | Most part of this document is written by Akira KIDA. 67 | Send comments/requests/bug reports to Akira KIDA at the above 68 | email address. 69 | 70 | ===================================================================== 71 | 72 | This Mini-Scheme Interpreter is based on "SCHEME Interpreter in 73 | Common Lisp" in Appendix of T.Matsuda & K.Saigo, Programming of LISP, 74 | archive No5 (1987) p6 - p42 (published in Japan). 75 | 76 | 77 | Copyright Notice: 78 | THIS SOFTWARE IS PLACED IN THE PUBLIC DOMAIN BY THE AUTHOR. 79 | 80 | This software is completely free to copy, modify and/or re-distribute. 81 | But I (Atsushi Moriwaki) would appreciate it if you left my name on the 82 | code as the author. 83 | 84 | DISCLAIMER: 85 | THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR 86 | IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED 87 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 88 | PURPOSE. 89 | 90 | 91 | Supported features (or, NOT supported features :-) 92 | 1) Lists, symbols, strings. 93 | However, strings have very limited capability. 94 | For instance, there is *NO* string-ref, string-set!, ... etc. 95 | 2) Numbers are limited to FIXNUM only. 96 | There is *NO* complex, real, rational and even bignum. 97 | 3) Macro feature is supported, though not the one defined in R4RS. 98 | 99 | Known problems: 100 | 1) Poor error recovery from illegal use of syntax and procedure. 101 | 2) Certain procedures do not check its argument type. 102 | 103 | Installation: 104 | 1) Select system declaration and configuration options by editing 105 | source file. 106 | 107 | You may choose one of the following systems by #define'ing 108 | the preprocessor symbol. 109 | 110 | Supported systems are: 111 | Macintosh: 112 | LSC -- LightSpeed C (3.0) for Macintosh 113 | LSC4 -- LightSpeed C (4.0) for Macintosh 114 | They are different in #include header only. 115 | I (kida) think THINK C 5.0, 6.0, 7.0 may be OK 116 | with LSC4 configuration, though not tested. 117 | MPW2 -- Macintosh Programmer's Workshop v2.0x 118 | I don't tested v3.x or later. 119 | DOS: 120 | MSC4 -- Microsoft C v4.0 (use /AL) 121 | MSC v5.1, v6.0, v7.0 are all OK. 122 | TURBO2 -- Bolarnd's Turbo C v2.0 (use -ml) 123 | Turbo C++ 1.0 is OK. 124 | UNIX: 125 | BSD -- UNIX of BSD flavor, ex. SuOS 4.x 126 | SYSV -- UNIX of System-V flavor, ex. Sun/Solaris 2.x 127 | 128 | VAX/VMS: 129 | VAXC -- VAX-C v3.x (this symbol may be defined by the 130 | compiler automatically). 131 | 132 | 2) Configure some preprocessor symbols by editing source files. 133 | 134 | Configurable #define's are: 135 | 136 | #define VERBOSE 137 | -- if defined, GC messages is verbose on default. 138 | 139 | #define AVOID_HACK_LOOP 140 | -- if defined, do _NOT_ use loop construction in the 141 | form 142 | do { ... } while (0) 143 | This form is used in macro expansion, since this is 144 | the best "safety" blocking construct when used in 145 | macro definition. 146 | However, some compiler (including SunPRO CC 2.0.1) 147 | is silly enough to warning this construct, like 148 | "warning: end-of-loop code not reached", etc. 149 | If you dislike such warning, please define this symbol. 150 | NOTE: You may get some "statement not reached" warning 151 | even if you have define this symbol. Please be patient, 152 | or, use more smart compiler. 153 | In short if you use GCC, undefine this and forget it 154 | at all. 155 | 156 | #define USE_SETJMP 157 | -- if defined, use setjmp to global jump on error. 158 | if not defined, avoid to use it. Compiled with 159 | this symbol defined, the interpreter issue fatal 160 | error and return to the operating system immediately 161 | when we run out of free cells. By default, i.e., 162 | compiled with this symbol is not defined, the 163 | interpreter will just return to the top level in 164 | such a case. 165 | May not be used except for compiling as Mac DA. 166 | 167 | #define USE_MACRO 168 | -- if defined, macro features are enabled. 169 | 170 | #define USE_QQUOTE 171 | -- if defined, you can use quasi-quote "`" in macro. 172 | You can use macro even if this symbol is undefined. 173 | 174 | 3) Compile! 175 | 176 | I think there is virtually no problem about how to compile. 177 | Since there is exactly one C source file. :-) 178 | If you are on UNIX boxes with some BSD flavors, instead of 179 | using make command, it's enough to type: 180 | 181 | cc -DBSD -O -o miniscm miniscm.c 182 | 183 | You may have additional warnings like 'function should 184 | return value'. This is due to omitting 'void' keyword 185 | from the source in order to get pre-ANSI compatibility. 186 | 187 | 188 | Usage : miniscm 189 | 190 | Sorry, no command line argnumet is allowed. 191 | 192 | 193 | Special procedures of this system: 194 | 195 | gc : (gc) -- force garbage collection 196 | 197 | gc-verbose : (gc-verbose bool) -- GC verbose on/off 198 | Argument #f turnes off the GC message. 199 | Enything else turn on the GC message. 200 | 201 | quit : (quit) -- quit to the operating system 202 | 203 | put : (put sym prop expr) 204 | -- set the value of a property of a symbol. 205 | get : (get sym prop) 206 | -- get the value of a property of a symbol. 207 | 208 | new-segment : (new-segment n) 209 | -- allocate n new cell segments. 210 | 211 | print-width : (print-width list) 212 | -- returns 'printed' width of list. 213 | 214 | closure? : (closure? obj) 215 | -- test if obj is a closure or not. 216 | 217 | macro? : (macro? obj) 218 | -- test if obj is a macro or not. 219 | note that a macro is also a closure. 220 | 221 | get-closure-code 222 | : (get-closure-code closure-obj) 223 | -- extract S-expr from closure-obj. 224 | 225 | Scheme files: 226 | init.scm -- Automatically loaded at invocation. 227 | Default setting assumes that this file is in the current 228 | working directory. 229 | Change #define InitFile if you don't like it. 230 | 231 | tools.scm -- This is a sample file. Contains very tiny pretty-print 232 | procedure. 233 | After invoking miniscm, type: 234 | (load "tools.scm") 235 | and try 236 | (pp getd) 237 | (pp do) 238 | 239 | Documents?: 240 | 241 | Sorry, there is no other documents. 242 | Do not ask one for me, please see the source instead. :-) 243 | 244 | But if you _absolutely_ need help, please email to me at: 245 | 246 | 247 | Enjoy! 248 | 249 | -- Akira KIDA 250 | Sysop for FPL in NIFTY-Serve in JAPAN. 251 | (FPL stands for 'Forum for Program-Language') 252 | 253 | -------------------------------------------------------------------------------- /init.scm: -------------------------------------------------------------------------------- 1 | ; This is a init file for Mini-Scheme. 2 | 3 | ;; fake pre R^3 boolean values 4 | (define nil #f) 5 | (define t #t) 6 | 7 | (define (caar x) (car (car x))) 8 | (define (cadr x) (car (cdr x))) 9 | (define (cdar x) (cdr (car x))) 10 | (define (cddr x) (cdr (cdr x))) 11 | (define (caaar x) (car (car (car x)))) 12 | (define (caadr x) (car (car (cdr x)))) 13 | (define (cadar x) (car (cdr (car x)))) 14 | (define (caddr x) (car (cdr (cdr x)))) 15 | (define (cdaar x) (cdr (car (car x)))) 16 | (define (cdadr x) (cdr (car (cdr x)))) 17 | (define (cddar x) (cdr (cdr (car x)))) 18 | (define (cdddr x) (cdr (cdr (cdr x)))) 19 | 20 | (define call/cc call-with-current-continuation) 21 | 22 | (define (list . x) x) 23 | 24 | (define (map proc list) 25 | (if (pair? list) 26 | (cons (proc (car list)) (map proc (cdr list))))) 27 | 28 | (define (for-each proc list) 29 | (if (pair? list) 30 | (begin (proc (car list)) (for-each proc (cdr list))) 31 | #t )) 32 | 33 | (define (list-tail x k) 34 | (if (zero? k) 35 | x 36 | (list-tail (cdr x) (- k 1)))) 37 | 38 | (define (list-ref x k) 39 | (car (list-tail x k))) 40 | 41 | (define (last-pair x) 42 | (if (pair? (cdr x)) 43 | (last-pair (cdr x)) 44 | x)) 45 | 46 | (define (head stream) (car stream)) 47 | 48 | (define (tail stream) (force (cdr stream))) 49 | 50 | ;; The following quasiquote macro is due to Eric S. Tiedemann. 51 | ;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. 52 | ;; 53 | ;; --- If you don't use macro or quasiquote, cut below. --- 54 | 55 | (macro 56 | quasiquote 57 | (lambda (l) 58 | (define (mcons f l r) 59 | (if (and (pair? r) 60 | (eq? (car r) 'quote) 61 | (eq? (car (cdr r)) (cdr f)) 62 | (pair? l) 63 | (eq? (car l) 'quote) 64 | (eq? (car (cdr l)) (car f))) 65 | (list 'quote f) 66 | (list 'cons l r))) 67 | (define (mappend f l r) 68 | (if (or (null? (cdr f)) 69 | (and (pair? r) 70 | (eq? (car r) 'quote) 71 | (eq? (car (cdr r)) '()))) 72 | l 73 | (list 'append l r))) 74 | (define (foo level form) 75 | (cond ((not (pair? form)) (list 'quote form)) 76 | ((eq? 'quasiquote (car form)) 77 | (mcons form ''quasiquote (foo (+ level 1) (cdr form)))) 78 | (#t (if (zero? level) 79 | (cond ((eq? (car form) 'unquote) (car (cdr form))) 80 | ((eq? (car form) 'unquote-splicing) 81 | (error "Unquote-splicing wasn't in a list:" 82 | form)) 83 | ((and (pair? (car form)) 84 | (eq? (car (car form)) 'unquote-splicing)) 85 | (mappend form (car (cdr (car form))) 86 | (foo level (cdr form)))) 87 | (#t (mcons form (foo level (car form)) 88 | (foo level (cdr form))))) 89 | (cond ((eq? (car form) 'unquote) 90 | (mcons form ''unquote (foo (- level 1) 91 | (cdr form)))) 92 | ((eq? (car form) 'unquote-splicing) 93 | (mcons form ''unquote-splicing 94 | (foo (- level 1) (cdr form)))) 95 | (#t (mcons form (foo level (car form)) 96 | (foo level (cdr form))))))))) 97 | (foo 0 (car (cdr l))))) 98 | 99 | ;;;;; following part is written by a.k 100 | 101 | ;;;; atom? 102 | (define (atom? x) 103 | (not (pair? x))) 104 | 105 | ;;;; memq 106 | (define (memq obj lst) 107 | (cond 108 | ((null? lst) #f) 109 | ((eq? obj (car lst)) lst) 110 | (else (memq obj (cdr lst))))) 111 | 112 | ;;;; equal? 113 | (define (equal? x y) 114 | (if (pair? x) 115 | (and (pair? y) 116 | (equal? (car x) (car y)) 117 | (equal? (cdr x) (cdr y))) 118 | (and (not (pair? y)) 119 | (eqv? x y)))) 120 | 121 | 122 | ;;;; (do ((var init inc) ...) (endtest result ...) body ...) 123 | ;; 124 | (macro do 125 | (lambda (do-macro) 126 | (apply (lambda (do vars endtest . body) 127 | (let ((do-loop (gensym))) 128 | `(letrec ((,do-loop 129 | (lambda ,(map (lambda (x) 130 | (if (pair? x) (car x) x)) 131 | `,vars) 132 | (if ,(car endtest) 133 | (begin ,@(cdr endtest)) 134 | (begin 135 | ,@body 136 | (,do-loop 137 | ,@(map (lambda (x) 138 | (cond 139 | ((not (pair? x)) x) 140 | ((< (length x) 3) (car x)) 141 | (else (car (cdr (cdr x)))))) 142 | `,vars))))))) 143 | (,do-loop 144 | ,@(map (lambda (x) 145 | (if (and (pair? x) (cdr x)) 146 | (car (cdr x)) 147 | nil)) 148 | `,vars))))) 149 | do-macro))) 150 | 151 | ;;;;; following part is written by c.p 152 | 153 | (define (list? x) 154 | (or (eq? x '()) 155 | (and (pair? x) 156 | (list? (cdr x))))) 157 | -------------------------------------------------------------------------------- /miniscm.c: -------------------------------------------------------------------------------- 1 | /* 2 | * ---------- Mini-Scheme Interpreter Version 0.85 ---------- 3 | * 4 | * coded by Atsushi Moriwaki (11/5/1989) 5 | * 6 | * E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp 7 | * 8 | * THIS SOFTWARE IS IN THE PUBLIC DOMAIN 9 | * ------------------------------------ 10 | * This software is completely free to copy, modify and/or re-distribute. 11 | * But I would appreciate it if you left my name on the code as the author. 12 | * 13 | */ 14 | /*-- 15 | * 16 | * This version has been modified by Chris Pressey. 17 | * current version is 0.85p1 (as yet unreleased) 18 | * 19 | * This version has been modified by R.C. Secrist. 20 | * 21 | * Mini-Scheme is now maintained by Akira KIDA. 22 | * 23 | * This is a revised and modified version by Akira KIDA. 24 | * current version is 0.85k4 (15 May 1994) 25 | * 26 | * Please send suggestions, bug reports and/or requests to: 27 | * 28 | *-- 29 | */ 30 | 31 | /* 32 | * Here is System declaration. 33 | * Please define exactly one symbol in the following section. 34 | */ 35 | /* #define LSC */ /* LightSpeed C for Macintosh */ 36 | /* #define LSC4 */ /* THINK C version 4.0 for Macintosh */ 37 | /* #define MPW2 */ /* Macintosh Programmer's Workshop v2.0x */ 38 | /* #define BSD */ /* 4.x BSD */ 39 | /* #define MSC */ /* Microsoft C Compiler v.4.00 - 7.00 */ 40 | /* #define TURBOC */ /* Turbo C compiler v.2.0, or TC++ 1.0 */ 41 | /* #define SYSV */ /* System-V, or POSIX */ 42 | /* #define VAXC */ /* VAX/VMS VAXC 2.x or later */ /* (automatic) */ 43 | 44 | #ifdef __BORLANDC__ /* Borland C++ - MS-DOS */ 45 | #define TURBOC 46 | #endif 47 | 48 | #ifdef __TURBOC__ /* Turbo C V1.5 - MS-DOS */ 49 | #define TURBOC 50 | #endif 51 | 52 | #ifdef mips /* DECstation running OSF/1 */ 53 | #define BSD 54 | #endif 55 | 56 | #ifdef __osf__ /* Alpha AXP running OSF/1 */ 57 | #define BSD 58 | #endif 59 | 60 | #ifdef __DECC /* Alpha AXP running VMS */ 61 | #define VAXC 62 | #endif 63 | 64 | #ifdef _AIX /* RS/6000 running AIX */ 65 | #define BSD 66 | #endif 67 | 68 | /* 69 | * Define or undefine following symbols as you need. 70 | */ 71 | /* #define VERBOSE */ /* define this if you want verbose GC */ 72 | #define AVOID_HACK_LOOP /* define this if your compiler is poor 73 | * enougth to complain "do { } while (0)" 74 | * construction. 75 | */ 76 | #define USE_SETJMP /* undef this if you do not want to use setjmp() */ 77 | #define USE_QQUOTE /* undef this if you do not need quasiquote */ 78 | #define USE_MACRO /* undef this if you do not need macro */ 79 | 80 | 81 | #ifdef USE_QQUOTE 82 | /*-- 83 | * If your machine can't support "forward single quotation character" 84 | * i.e., '`', you may have trouble to use backquote. 85 | * So use '^' in place of '`'. 86 | */ 87 | # define BACKQUOTE '`' 88 | #endif 89 | 90 | /* 91 | * Basic memory allocation units 92 | */ 93 | 94 | #ifdef TURBOC /* rcs */ 95 | #define CELL_SEGSIZE 2048 96 | #define CELL_NSEGMENT 100 97 | #define STR_SEGSIZE 2048 98 | #define STR_NSEGMENT 100 99 | #else 100 | #define CELL_SEGSIZE 5000 /* # of cells in one segment */ 101 | #define CELL_NSEGMENT 100 /* # of segments for cells */ 102 | #define STR_SEGSIZE 2500 /* bytes of one string segment */ 103 | #define STR_NSEGMENT 100 /* # of segments for strings */ 104 | #endif 105 | 106 | 107 | 108 | #define banner "Hello, This is Mini-Scheme Interpreter Version 0.85p1.\n" 109 | 110 | 111 | #include 112 | #include 113 | #ifdef USE_SETJMP 114 | #include 115 | #endif 116 | 117 | 118 | /* System dependency */ 119 | #ifdef LSC 120 | #include 121 | #include 122 | #define malloc(x) NewPtr((long)(x)) 123 | #define prompt "> " 124 | #define InitFile "init.scm" 125 | #define FIRST_CELLSEGS 5 126 | #endif 127 | 128 | #ifdef LSC4 129 | #include 130 | #include 131 | #define malloc(x) NewPtr((long)(x)) 132 | #define prompt "> " 133 | #define InitFile "init.scm" 134 | #define FIRST_CELLSEGS 5 135 | #endif 136 | 137 | #ifdef MPW2 138 | #include 139 | #include 140 | #define malloc(x) NewPtr((long)(x)) 141 | #define prompt "> [enter at next line]\n" 142 | #define InitFile "init.scm" 143 | #define FIRST_CELLSEGS 5 144 | #endif 145 | 146 | #ifdef BSD 147 | #include 148 | #include 149 | #include 150 | #define prompt "> " 151 | #define InitFile "init.scm" 152 | #define FIRST_CELLSEGS 10 153 | #endif 154 | 155 | #ifdef MSC 156 | #include 157 | #include 158 | #include 159 | #include 160 | #define prompt "> " 161 | #define InitFile "init.scm" 162 | #define FIRST_CELLSEGS 3 163 | #endif 164 | 165 | #ifdef TURBOC 166 | #include 167 | #include 168 | #define prompt "> " 169 | #define InitFile "init.scm" 170 | #define FIRST_CELLSEGS 3 171 | #endif 172 | 173 | #ifdef SYSV 174 | #include 175 | #include 176 | #if __STDC__ 177 | # include 178 | #endif 179 | #define prompt "> " 180 | #define InitFile "init.scm" 181 | #define FIRST_CELLSEGS 10 182 | #endif 183 | 184 | #ifdef VAXC 185 | #include 186 | #include 187 | #define prompt "> " 188 | #define InitFile "init.scm" 189 | #define FIRST_CELLSEGS 10 190 | #endif 191 | 192 | #ifdef __GNUC__ 193 | /* 194 | * If we use gcc, AVOID_HACK_LOOP is unnecessary 195 | */ 196 | #undef AVOID_HACK_LOOP 197 | #endif 198 | 199 | #ifndef FIRST_CELLSEGS 200 | #error Please define your system type. 201 | /* 202 | * We refrain this to raise an error anyway even if on pre-ANSI system. 203 | */ 204 | error Please define your system type. 205 | #endif 206 | 207 | /* cell structure */ 208 | struct cell { 209 | unsigned short _flag; 210 | union { 211 | struct { 212 | char *_svalue; 213 | short _keynum; 214 | } _string; 215 | struct { 216 | long _ivalue; 217 | } _number; 218 | struct { 219 | struct cell *_car; 220 | struct cell *_cdr; 221 | } _cons; 222 | } _object; 223 | }; 224 | 225 | typedef struct cell *pointer; 226 | 227 | #define T_STRING 1 /* 0000000000000001 */ 228 | #define T_NUMBER 2 /* 0000000000000010 */ 229 | #define T_SYMBOL 4 /* 0000000000000100 */ 230 | #define T_SYNTAX 8 /* 0000000000001000 */ 231 | #define T_PROC 16 /* 0000000000010000 */ 232 | #define T_PAIR 32 /* 0000000000100000 */ 233 | #define T_CLOSURE 64 /* 0000000001000000 */ 234 | #define T_CONTINUATION 128 /* 0000000010000000 */ 235 | #ifdef USE_MACRO 236 | # define T_MACRO 256 /* 0000000100000000 */ 237 | #endif 238 | #define T_PROMISE 512 /* 0000001000000000 */ 239 | #define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ 240 | #define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ 241 | #define MARK 32768 /* 1000000000000000 */ 242 | #define UNMARK 32767 /* 0111111111111111 */ 243 | 244 | /* macros for cell operations */ 245 | #define type(p) ((p)->_flag) 246 | 247 | #define isstring(p) (type(p)&T_STRING) 248 | #define strvalue(p) ((p)->_object._string._svalue) 249 | #define keynum(p) ((p)->_object._string._keynum) 250 | 251 | #define isnumber(p) (type(p)&T_NUMBER) 252 | #define ivalue(p) ((p)->_object._number._ivalue) 253 | 254 | #define ispair(p) (type(p)&T_PAIR) 255 | #define car(p) ((p)->_object._cons._car) 256 | #define cdr(p) ((p)->_object._cons._cdr) 257 | 258 | #define issymbol(p) (type(p)&T_SYMBOL) 259 | #define symname(p) strvalue(car(p)) 260 | #define hasprop(p) (type(p)&T_SYMBOL) 261 | #define symprop(p) cdr(p) 262 | 263 | #define issyntax(p) (type(p)&T_SYNTAX) 264 | #define isproc(p) (type(p)&T_PROC) 265 | #define syntaxname(p) strvalue(car(p)) 266 | #define syntaxnum(p) keynum(car(p)) 267 | #define procnum(p) ivalue(p) 268 | 269 | #define isclosure(p) (type(p)&T_CLOSURE) 270 | #ifdef USE_MACRO 271 | # define ismacro(p) (type(p)&T_MACRO) 272 | #endif 273 | #define closure_code(p) car(p) 274 | #define closure_env(p) cdr(p) 275 | 276 | #define iscontinuation(p) (type(p)&T_CONTINUATION) 277 | #define cont_dump(p) cdr(p) 278 | 279 | #define ispromise(p) (type(p)&T_PROMISE) 280 | #define setpromise(p) type(p) |= T_PROMISE 281 | 282 | #define isatom(p) (type(p)&T_ATOM) 283 | #define setatom(p) type(p) |= T_ATOM 284 | #define clratom(p) type(p) &= CLRATOM 285 | 286 | #define ismark(p) (type(p)&MARK) 287 | #define setmark(p) type(p) |= MARK 288 | #define clrmark(p) type(p) &= UNMARK 289 | 290 | #define caar(p) car(car(p)) 291 | #define cadr(p) car(cdr(p)) 292 | #define cdar(p) cdr(car(p)) 293 | #define cddr(p) cdr(cdr(p)) 294 | #define cadar(p) car(cdr(car(p))) 295 | #define caddr(p) car(cdr(cdr(p))) 296 | #define cadaar(p) car(cdr(car(car(p)))) 297 | #define cadddr(p) car(cdr(cdr(cdr(p)))) 298 | #define cddddr(p) cdr(cdr(cdr(cdr(p)))) 299 | 300 | /* arrays for segments */ 301 | pointer cell_seg[CELL_NSEGMENT]; 302 | int last_cell_seg = -1; 303 | char *str_seg[STR_NSEGMENT]; 304 | int str_seglast = -1; 305 | 306 | /* We use 4 registers. */ 307 | pointer args; /* register for arguments of function */ 308 | pointer envir; /* stack register for current environment */ 309 | pointer code; /* register for current code */ 310 | pointer dump; /* stack register for next evaluation */ 311 | 312 | struct cell _NIL; 313 | pointer NIL = &_NIL; /* special cell representing empty cell */ 314 | struct cell _T; 315 | pointer T = &_T; /* special cell representing #t */ 316 | struct cell _F; 317 | pointer F = &_F; /* special cell representing #f */ 318 | pointer oblist = &_NIL; /* pointer to symbol table */ 319 | pointer global_env; /* pointer to global environment */ 320 | 321 | /* global pointers to special symbols */ 322 | pointer LAMBDA; /* pointer to syntax lambda */ 323 | pointer QUOTE; /* pointer to syntax quote */ 324 | 325 | #ifdef USE_QQUOTE 326 | pointer QQUOTE; /* pointer to symbol quasiquote */ 327 | pointer UNQUOTE; /* pointer to symbol unquote */ 328 | pointer UNQUOTESP; /* pointer to symbol unquote-splicing */ 329 | 330 | #endif 331 | 332 | pointer free_cell = &_NIL; /* pointer to top of free cells */ 333 | long fcells = 0; /* # of free cells */ 334 | 335 | FILE *infp; /* input file */ 336 | FILE *outfp; /* output file */ 337 | 338 | #ifdef USE_SETJMP 339 | jmp_buf error_jmp; 340 | 341 | #endif 342 | char gc_verbose; /* if gc_verbose is not zero, print gc status */ 343 | int quiet = 0; /* if not zero, print banner, prompt, results */ 344 | int all_errors_fatal = 0; /* if not zero, every error is a FatalError */ 345 | 346 | /* allocate new cell segment */ 347 | alloc_cellseg(n) 348 | int n; 349 | { 350 | register pointer p; 351 | register long i; 352 | register int k; 353 | 354 | for (k = 0; k < n; k++) { 355 | if (last_cell_seg >= CELL_NSEGMENT - 1) 356 | return k; 357 | p = (pointer) malloc(CELL_SEGSIZE * sizeof(struct cell)); 358 | if (p == (pointer) 0) 359 | return k; 360 | cell_seg[++last_cell_seg] = p; 361 | fcells += CELL_SEGSIZE; 362 | for (i = 0; i < CELL_SEGSIZE - 1; i++, p++) { 363 | type(p) = 0; 364 | car(p) = NIL; 365 | cdr(p) = p + 1; 366 | } 367 | type(p) = 0; 368 | car(p) = NIL; 369 | cdr(p) = free_cell; 370 | free_cell = cell_seg[last_cell_seg]; 371 | } 372 | return n; 373 | } 374 | 375 | /* allocate new string segment */ 376 | alloc_strseg(n) 377 | int n; 378 | { 379 | register char *p; 380 | register long i; 381 | register int k; 382 | 383 | for (k = 0; k < n; k++) { 384 | if (str_seglast >= STR_NSEGMENT) 385 | return k; 386 | p = (char *) malloc(STR_SEGSIZE * sizeof(char)); 387 | if (p == (char *) 0) 388 | return k; 389 | str_seg[++str_seglast] = p; 390 | for (i = 0; i < STR_SEGSIZE; i++) 391 | *p++ = (char) (-1); 392 | } 393 | return n; 394 | } 395 | 396 | /* initialization of Mini-Scheme */ 397 | init_scheme() 398 | { 399 | register pointer i; 400 | 401 | if (alloc_cellseg(FIRST_CELLSEGS) != FIRST_CELLSEGS) 402 | FatalError("Unable to allocate initial cell segments"); 403 | if (!alloc_strseg(1)) 404 | FatalError("Unable to allocate initial string segments"); 405 | #ifdef VERBOSE 406 | gc_verbose = 1; 407 | #else 408 | gc_verbose = 0; 409 | #endif 410 | init_globals(); 411 | } 412 | 413 | /* get new cell. parameter a, b is marked by gc. */ 414 | pointer get_cell(a, b) 415 | register pointer a, b; 416 | { 417 | register pointer x; 418 | 419 | if (free_cell == NIL) { 420 | gc(a, b); 421 | if (free_cell == NIL) 422 | #ifdef USE_SETJMP 423 | if (!alloc_cellseg(1)) { 424 | args = envir = code = dump = NIL; 425 | gc(NIL, NIL); 426 | if (free_cell != NIL) 427 | Error("run out of cells --- rerurn to top level"); 428 | else 429 | FatalError("run out of cells --- unable to recover cells"); 430 | } 431 | #else 432 | if (!alloc_cellseg(1)) 433 | FatalError("run out of cells --- unable to recover cells"); 434 | #endif 435 | } 436 | x = free_cell; 437 | free_cell = cdr(x); 438 | --fcells; 439 | return (x); 440 | } 441 | 442 | /* get new cons cell */ 443 | pointer cons(a, b) 444 | register pointer a, b; 445 | { 446 | register pointer x = get_cell(a, b); 447 | 448 | type(x) = T_PAIR; 449 | car(x) = a; 450 | cdr(x) = b; 451 | return (x); 452 | } 453 | 454 | /* get number atom */ 455 | pointer mk_number(num) 456 | register long num; 457 | { 458 | register pointer x = get_cell(NIL, NIL); 459 | 460 | type(x) = (T_NUMBER | T_ATOM); 461 | ivalue(x) = num; 462 | return (x); 463 | } 464 | 465 | /* allocate name to string area */ 466 | char *store_string(name) 467 | char *name; 468 | { 469 | register char *q; 470 | register short i; 471 | long len, remain; 472 | 473 | /* first check name has already listed */ 474 | for (i = 0; i <= str_seglast; i++) 475 | for (q = str_seg[i]; *q != (char) (-1); ) { 476 | if (!strcmp(q, name)) 477 | goto FOUND; 478 | while (*q++) 479 | ; /* get next string */ 480 | } 481 | len = strlen(name) + 2; 482 | remain = (long) STR_SEGSIZE - ((long) q - (long) str_seg[str_seglast]); 483 | if (remain < len) { 484 | if (!alloc_strseg(1)) 485 | FatalError("run out of string area"); 486 | q = str_seg[str_seglast]; 487 | } 488 | strcpy(q, name); 489 | FOUND: 490 | return (q); 491 | } 492 | 493 | /* get new string */ 494 | pointer mk_string(str) 495 | char *str; 496 | { 497 | register pointer x = get_cell(NIL, NIL); 498 | 499 | strvalue(x) = store_string(str); 500 | type(x) = (T_STRING | T_ATOM); 501 | keynum(x) = (short) (-1); 502 | return (x); 503 | } 504 | 505 | /* get new symbol */ 506 | pointer mk_symbol(name) 507 | char *name; 508 | { 509 | register pointer x; 510 | 511 | /* fisrt check oblist */ 512 | for (x = oblist; x != NIL; x = cdr(x)) 513 | if (!strcmp(name, symname(car(x)))) 514 | break; 515 | 516 | if (x != NIL) 517 | return (car(x)); 518 | else { 519 | x = cons(mk_string(name), NIL); 520 | type(x) = T_SYMBOL; 521 | oblist = cons(x, oblist); 522 | return (x); 523 | } 524 | } 525 | 526 | /* make symbol or number atom from string */ 527 | pointer mk_atom(q) 528 | char *q; 529 | { 530 | char c, *p; 531 | 532 | p = q; 533 | if (!isdigit(c = *p++)) { 534 | if ((c != '+' && c != '-') || !isdigit(*p)) 535 | return (mk_symbol(q)); 536 | } 537 | for ( ; (c = *p) != 0; ++p) 538 | if (!isdigit(c)) 539 | return (mk_symbol(q)); 540 | return (mk_number(atol(q))); 541 | } 542 | 543 | /* make constant */ 544 | pointer mk_const(name) 545 | char *name; 546 | { 547 | long x; 548 | char tmp[256]; 549 | 550 | if (!strcmp(name, "t")) 551 | return (T); 552 | else if (!strcmp(name, "f")) 553 | return (F); 554 | else if (*name == 'o') {/* #o (octal) */ 555 | sprintf(tmp, "0%s", &name[1]); 556 | sscanf(tmp, "%lo", (unsigned long int *)&x); 557 | return (mk_number(x)); 558 | } else if (*name == 'd') { /* #d (decimal) */ 559 | sscanf(&name[1], "%ld", &x); 560 | return (mk_number(x)); 561 | } else if (*name == 'x') { /* #x (hex) */ 562 | sprintf(tmp, "0x%s", &name[1]); 563 | sscanf(tmp, "%lx", (unsigned long int *)&x); 564 | return (mk_number(x)); 565 | } else 566 | return (NIL); 567 | } 568 | 569 | 570 | /* ========== garbage collector ========== */ 571 | 572 | /*-- 573 | * We use algorithm E (Kunuth, The Art of Computer Programming Vol.1, 574 | * sec.3.5) for marking. 575 | */ 576 | mark(a) 577 | pointer a; 578 | { 579 | register pointer t, q, p; 580 | 581 | E1: t = (pointer) 0; 582 | p = a; 583 | E2: setmark(p); 584 | E3: if (isatom(p)) 585 | goto E6; 586 | E4: q = car(p); 587 | if (q && !ismark(q)) { 588 | setatom(p); 589 | car(p) = t; 590 | t = p; 591 | p = q; 592 | goto E2; 593 | } 594 | E5: q = cdr(p); 595 | if (q && !ismark(q)) { 596 | cdr(p) = t; 597 | t = p; 598 | p = q; 599 | goto E2; 600 | } 601 | E6: if (!t) 602 | return; 603 | q = t; 604 | if (isatom(q)) { 605 | clratom(q); 606 | t = car(q); 607 | car(q) = p; 608 | p = q; 609 | goto E5; 610 | } else { 611 | t = cdr(q); 612 | cdr(q) = p; 613 | p = q; 614 | goto E6; 615 | } 616 | } 617 | 618 | 619 | /* garbage collection. parameter a, b is marked. */ 620 | gc(a, b) 621 | register pointer a, b; 622 | { 623 | register pointer p; 624 | register short i; 625 | register long j; 626 | 627 | if (gc_verbose) 628 | printf("gc..."); 629 | 630 | /* mark system globals */ 631 | mark(oblist); 632 | mark(global_env); 633 | 634 | /* mark current registers */ 635 | mark(args); 636 | mark(envir); 637 | mark(code); 638 | mark(dump); 639 | 640 | /* mark variables a, b */ 641 | mark(a); 642 | mark(b); 643 | 644 | /* garbage collect */ 645 | clrmark(NIL); 646 | fcells = 0; 647 | free_cell = NIL; 648 | for (i = 0; i <= last_cell_seg; i++) { 649 | for (j = 0, p = cell_seg[i]; j < CELL_SEGSIZE; j++, p++) { 650 | if (ismark(p)) 651 | clrmark(p); 652 | else { 653 | type(p) = 0; 654 | cdr(p) = free_cell; 655 | car(p) = NIL; 656 | free_cell = p; 657 | ++fcells; 658 | } 659 | } 660 | } 661 | 662 | if (gc_verbose) 663 | printf(" done %ld cells are recovered.\n", fcells); 664 | } 665 | 666 | 667 | /* ========== Rootines for Reading ========== */ 668 | 669 | #define TOK_LPAREN 0 670 | #define TOK_RPAREN 1 671 | #define TOK_DOT 2 672 | #define TOK_ATOM 3 673 | #define TOK_QUOTE 4 674 | #define TOK_COMMENT 5 675 | #define TOK_DQUOTE 6 676 | #ifdef USE_QQUOTE 677 | # define TOK_BQUOTE 7 678 | # define TOK_COMMA 8 679 | # define TOK_ATMARK 9 680 | #endif 681 | #define TOK_SHARP 10 682 | 683 | #define LINESIZE 1024 684 | char linebuff[LINESIZE]; 685 | char strbuff[256]; 686 | char *currentline = linebuff; 687 | char *endline = linebuff; 688 | 689 | /* get new character from input file */ 690 | int inchar() 691 | { 692 | if (currentline >= endline) { /* input buffer is empty */ 693 | if (feof(infp)) { 694 | fclose(infp); 695 | infp = stdin; 696 | if (!quiet) 697 | printf(prompt); 698 | } 699 | strcpy(linebuff, "\n"); 700 | if (fgets(currentline = linebuff, LINESIZE, infp) == NULL) 701 | if (infp == stdin) { 702 | if (!quiet) 703 | fprintf(stderr, "Good-bye\n"); 704 | exit(0); 705 | } 706 | endline = linebuff + strlen(linebuff); 707 | } 708 | return (*currentline++); 709 | } 710 | 711 | /* clear input buffer */ 712 | clearinput() 713 | { 714 | currentline = endline = linebuff; 715 | } 716 | 717 | /* back to standard input */ 718 | flushinput() 719 | { 720 | if (infp != stdin) { 721 | fclose(infp); 722 | infp = stdin; 723 | } 724 | clearinput(); 725 | } 726 | 727 | /* back character to input buffer */ 728 | backchar() 729 | { 730 | currentline--; 731 | } 732 | 733 | /* read chacters to delimiter */ 734 | char *readstr(delim) 735 | char *delim; 736 | { 737 | char *p = strbuff; 738 | 739 | while (isdelim(delim, (*p++ = inchar()))) 740 | ; 741 | backchar(); 742 | *--p = '\0'; 743 | return (strbuff); 744 | } 745 | 746 | /* read string expression "xxx...xxx" */ 747 | char *readstrexp() 748 | { 749 | char c, *p = strbuff; 750 | 751 | for (;;) { 752 | if ((c = inchar()) != '"') 753 | *p++ = c; 754 | else if (p > strbuff && *(p - 1) == '\\') 755 | *(p - 1) = '"'; 756 | else { 757 | *p = '\0'; 758 | return (strbuff); 759 | } 760 | } 761 | } 762 | 763 | /* check c is delimiter */ 764 | isdelim(s, c) 765 | char *s; 766 | char c; 767 | { 768 | while (*s) 769 | if (*s++ == c) 770 | return (0); 771 | return (1); 772 | } 773 | 774 | /* skip white characters */ 775 | skipspace() 776 | { 777 | while (isspace(inchar())) 778 | ; 779 | backchar(); 780 | } 781 | 782 | /* get token */ 783 | token() 784 | { 785 | skipspace(); 786 | switch (inchar()) { 787 | case '(': 788 | return (TOK_LPAREN); 789 | case ')': 790 | return (TOK_RPAREN); 791 | case '.': 792 | return (TOK_DOT); 793 | case '\'': 794 | return (TOK_QUOTE); 795 | case ';': 796 | return (TOK_COMMENT); 797 | case '"': 798 | return (TOK_DQUOTE); 799 | #ifdef USE_QQUOTE 800 | case BACKQUOTE: 801 | return (TOK_BQUOTE); 802 | case ',': 803 | if (inchar() == '@') 804 | return (TOK_ATMARK); 805 | else { 806 | backchar(); 807 | return (TOK_COMMA); 808 | } 809 | #endif 810 | case '#': 811 | return (TOK_SHARP); 812 | default: 813 | backchar(); 814 | return (TOK_ATOM); 815 | } 816 | } 817 | 818 | /* ========== Rootines for Printing ========== */ 819 | #define ok_abbrev(x) (ispair(x) && cdr(x) == NIL) 820 | 821 | strunquote(p, s) 822 | char *p; 823 | char *s; 824 | { 825 | *p++ = '"'; 826 | for ( ; *s; ++s) { 827 | if (*s == '"') { 828 | *p++ = '\\'; 829 | *p++ = '"'; 830 | } else if (*s == '\n') { 831 | *p++ = '\\'; 832 | *p++ = 'n'; 833 | } else 834 | *p++ = *s; 835 | } 836 | *p++ = '"'; 837 | *p = '\0'; 838 | } 839 | 840 | 841 | /* print atoms */ 842 | int printatom(l, f) 843 | pointer l; 844 | int f; 845 | { 846 | char *p; 847 | 848 | if (l == NIL) 849 | p = "()"; 850 | else if (l == T) 851 | p = "#t"; 852 | else if (l == F) 853 | p = "#f"; 854 | else if (isnumber(l)) { 855 | p = strbuff; 856 | sprintf(p, "%ld", ivalue(l)); 857 | } else if (isstring(l)) { 858 | if (!f) 859 | p = strvalue(l); 860 | else { 861 | p = strbuff; 862 | strunquote(p, strvalue(l)); 863 | } 864 | } else if (issymbol(l)) 865 | p = symname(l); 866 | else if (isproc(l)) { 867 | p = strbuff; 868 | sprintf(p, "#", procnum(l)); 869 | #ifdef USE_MACRO 870 | } else if (ismacro(l)) { 871 | p = "#"; 872 | #endif 873 | } else if (isclosure(l)) 874 | p = "#"; 875 | else if (iscontinuation(l)) 876 | p = "#"; 877 | if (f < 0) 878 | return strlen(p); 879 | fputs(p, outfp); 880 | return 0; 881 | } 882 | 883 | 884 | /* ========== Rootines for Evaluation Cycle ========== */ 885 | 886 | /* make closure. c is code. e is environment */ 887 | pointer mk_closure(c, e) 888 | register pointer c, e; 889 | { 890 | register pointer x = get_cell(c, e); 891 | 892 | type(x) = T_CLOSURE; 893 | car(x) = c; 894 | cdr(x) = e; 895 | return (x); 896 | } 897 | 898 | /* make continuation. */ 899 | pointer mk_continuation(d) 900 | register pointer d; 901 | { 902 | register pointer x = get_cell(NIL, d); 903 | 904 | type(x) = T_CONTINUATION; 905 | cont_dump(x) = d; 906 | return (x); 907 | } 908 | 909 | /* reverse list -- make new cells */ 910 | pointer reverse(a) 911 | register pointer a; /* a must be checked by gc */ 912 | { 913 | register pointer p = NIL; 914 | 915 | for ( ; ispair(a); a = cdr(a)) 916 | p = cons(car(a), p); 917 | return (p); 918 | } 919 | 920 | /* reverse list --- no make new cells */ 921 | pointer non_alloc_rev(term, list) 922 | pointer term, list; 923 | { 924 | register pointer p = list, result = term, q; 925 | 926 | while (p != NIL) { 927 | q = cdr(p); 928 | cdr(p) = result; 929 | result = p; 930 | p = q; 931 | } 932 | return (result); 933 | } 934 | 935 | /* append list -- make new cells */ 936 | pointer append(a, b) 937 | register pointer a, b; 938 | { 939 | register pointer p = b, q; 940 | 941 | if (a != NIL) { 942 | a = reverse(a); 943 | while (a != NIL) { 944 | q = cdr(a); 945 | cdr(a) = p; 946 | p = a; 947 | a = q; 948 | } 949 | } 950 | return (p); 951 | } 952 | 953 | /* equivalence of atoms */ 954 | eqv(a, b) 955 | register pointer a, b; 956 | { 957 | if (isstring(a)) { 958 | if (isstring(b)) 959 | return (strvalue(a) == strvalue(b)); 960 | else 961 | return (0); 962 | } else if (isnumber(a)) { 963 | if (isnumber(b)) 964 | return (ivalue(a) == ivalue(b)); 965 | else 966 | return (0); 967 | } else 968 | return (a == b); 969 | } 970 | 971 | /* true or false value macro */ 972 | #define istrue(p) ((p) != NIL && (p) != F) 973 | #define isfalse(p) ((p) == NIL || (p) == F) 974 | 975 | /* Error macro */ 976 | #ifdef AVOID_HACK_LOOP 977 | # define BEGIN { 978 | # define END } 979 | #else 980 | /* 981 | * I believe this is better, but some compiler complains.... 982 | */ 983 | # define BEGIN do { 984 | # define END } while (0) 985 | #endif 986 | 987 | #define Error_0(s) BEGIN \ 988 | args = cons(mk_string((s)), NIL); \ 989 | operator = (short)OP_ERR0; \ 990 | return T; END 991 | 992 | #define Error_1(s, a) BEGIN \ 993 | args = cons((a), NIL); \ 994 | args = cons(mk_string((s)), args); \ 995 | operator = (short)OP_ERR0; \ 996 | return T; END 997 | 998 | /* control macros for Eval_Cycle */ 999 | #define s_goto(a) BEGIN \ 1000 | operator = (short)(a); \ 1001 | return T; END 1002 | 1003 | #define s_save(a, b, c) ( \ 1004 | dump = cons(envir, cons((c), dump)), \ 1005 | dump = cons((b), dump), \ 1006 | dump = cons(mk_number((long)(a)), dump)) \ 1007 | 1008 | 1009 | #define s_return(a) BEGIN \ 1010 | value = (a); \ 1011 | operator = ivalue(car(dump)); \ 1012 | args = cadr(dump); \ 1013 | envir = caddr(dump); \ 1014 | code = cadddr(dump); \ 1015 | dump = cddddr(dump); \ 1016 | return T; END 1017 | 1018 | #define s_retbool(tf) s_return((tf) ? T : F) 1019 | 1020 | 1021 | 1022 | /* ========== Evaluation Cycle ========== */ 1023 | 1024 | /* operator code */ 1025 | #define OP_LOAD 0 1026 | #define OP_T0LVL 1 1027 | #define OP_T1LVL 2 1028 | #define OP_READ 3 1029 | #define OP_VALUEPRINT 4 1030 | #define OP_EVAL 5 1031 | #define OP_E0ARGS 6 1032 | #define OP_E1ARGS 7 1033 | #define OP_APPLY 8 1034 | #define OP_DOMACRO 9 1035 | 1036 | #define OP_LAMBDA 10 1037 | #define OP_QUOTE 11 1038 | #define OP_DEF0 12 1039 | #define OP_DEF1 13 1040 | #define OP_BEGIN 14 1041 | #define OP_IF0 15 1042 | #define OP_IF1 16 1043 | #define OP_SET0 17 1044 | #define OP_SET1 18 1045 | #define OP_LET0 19 1046 | #define OP_LET1 20 1047 | #define OP_LET2 21 1048 | #define OP_LET0AST 22 1049 | #define OP_LET1AST 23 1050 | #define OP_LET2AST 24 1051 | #define OP_LET0REC 25 1052 | #define OP_LET1REC 26 1053 | #define OP_LET2REC 27 1054 | #define OP_COND0 28 1055 | #define OP_COND1 29 1056 | #define OP_DELAY 30 1057 | #define OP_AND0 31 1058 | #define OP_AND1 32 1059 | #define OP_OR0 33 1060 | #define OP_OR1 34 1061 | #define OP_C0STREAM 35 1062 | #define OP_C1STREAM 36 1063 | #define OP_0MACRO 37 1064 | #define OP_1MACRO 38 1065 | #define OP_CASE0 39 1066 | #define OP_CASE1 40 1067 | #define OP_CASE2 41 1068 | 1069 | #define OP_PEVAL 42 1070 | #define OP_PAPPLY 43 1071 | #define OP_CONTINUATION 44 1072 | #define OP_ADD 45 1073 | #define OP_SUB 46 1074 | #define OP_MUL 47 1075 | #define OP_DIV 48 1076 | #define OP_REM 49 1077 | #define OP_CAR 50 1078 | #define OP_CDR 51 1079 | #define OP_CONS 52 1080 | #define OP_SETCAR 53 1081 | #define OP_SETCDR 54 1082 | #define OP_NOT 55 1083 | #define OP_BOOL 56 1084 | #define OP_NULL 57 1085 | #define OP_ZEROP 58 1086 | #define OP_POSP 59 1087 | #define OP_NEGP 60 1088 | #define OP_NEQ 61 1089 | #define OP_LESS 62 1090 | #define OP_GRE 63 1091 | #define OP_LEQ 64 1092 | #define OP_GEQ 65 1093 | #define OP_SYMBOL 66 1094 | #define OP_NUMBER 67 1095 | #define OP_STRING 68 1096 | #define OP_PROC 69 1097 | #define OP_PAIR 70 1098 | #define OP_EQ 71 1099 | #define OP_EQV 72 1100 | #define OP_FORCE 73 1101 | #define OP_WRITE 74 1102 | #define OP_DISPLAY 75 1103 | #define OP_NEWLINE 76 1104 | #define OP_ERR0 77 1105 | #define OP_ERR1 78 1106 | #define OP_REVERSE 79 1107 | #define OP_APPEND 80 1108 | #define OP_PUT 81 1109 | #define OP_GET 82 1110 | #define OP_QUIT 83 1111 | #define OP_GC 84 1112 | #define OP_GCVERB 85 1113 | #define OP_NEWSEGMENT 86 1114 | 1115 | #define OP_RDSEXPR 87 1116 | #define OP_RDLIST 88 1117 | #define OP_RDDOT 89 1118 | #define OP_RDQUOTE 90 1119 | #define OP_RDQQUOTE 91 1120 | #define OP_RDUNQUOTE 92 1121 | #define OP_RDUQTSP 93 1122 | 1123 | #define OP_P0LIST 94 1124 | #define OP_P1LIST 95 1125 | 1126 | #define OP_LIST_LENGTH 96 1127 | #define OP_ASSQ 97 1128 | #define OP_PRINT_WIDTH 98 1129 | #define OP_P0_WIDTH 99 1130 | #define OP_P1_WIDTH 100 1131 | #define OP_GET_CLOSURE 101 1132 | #define OP_CLOSUREP 102 1133 | #define OP_MACROP 103 1134 | 1135 | 1136 | static FILE *tmpfp; 1137 | static int tok; 1138 | static int print_flag; 1139 | static pointer value; 1140 | static short operator; 1141 | 1142 | pointer opexe_0(op) 1143 | register short op; 1144 | { 1145 | register pointer x, y; 1146 | 1147 | switch (op) { 1148 | case OP_LOAD: /* load */ 1149 | if (!isstring(car(args))) { 1150 | Error_0("load -- argument is not string"); 1151 | } 1152 | if ((infp = fopen(strvalue(car(args)), "r")) == NULL) { 1153 | infp = stdin; 1154 | Error_1("Unable to open", car(args)); 1155 | } 1156 | if (!quiet) 1157 | fprintf(outfp, "loading %s", strvalue(car(args))); 1158 | s_goto(OP_T0LVL); 1159 | 1160 | case OP_T0LVL: /* top level */ 1161 | if (!quiet) 1162 | fprintf(outfp, "\n"); 1163 | dump = NIL; 1164 | envir = global_env; 1165 | s_save(OP_VALUEPRINT, NIL, NIL); 1166 | s_save(OP_T1LVL, NIL, NIL); 1167 | if (infp == stdin && !quiet) 1168 | printf(prompt); 1169 | s_goto(OP_READ); 1170 | 1171 | case OP_T1LVL: /* top level */ 1172 | code = value; 1173 | s_goto(OP_EVAL); 1174 | 1175 | case OP_READ: /* read */ 1176 | tok = token(); 1177 | s_goto(OP_RDSEXPR); 1178 | 1179 | case OP_VALUEPRINT: /* print evalution result */ 1180 | print_flag = 1; 1181 | args = value; 1182 | if (quiet) { 1183 | s_goto(OP_T0LVL); 1184 | } else { 1185 | s_save(OP_T0LVL, NIL, NIL); 1186 | s_goto(OP_P0LIST); 1187 | } 1188 | 1189 | case OP_EVAL: /* main part of evalution */ 1190 | if (issymbol(code)) { /* symbol */ 1191 | for (x = envir; x != NIL; x = cdr(x)) { 1192 | for (y = car(x); y != NIL; y = cdr(y)) 1193 | if (caar(y) == code) 1194 | break; 1195 | if (y != NIL) 1196 | break; 1197 | } 1198 | if (x != NIL) { 1199 | s_return(cdar(y)); 1200 | } else { 1201 | Error_1("Unbounded variable", code); 1202 | } 1203 | } else if (ispair(code)) { 1204 | if (issyntax(x = car(code))) { /* SYNTAX */ 1205 | code = cdr(code); 1206 | s_goto(syntaxnum(x)); 1207 | } else {/* first, eval top element and eval arguments */ 1208 | #ifdef USE_MACRO 1209 | s_save(OP_E0ARGS, NIL, code); 1210 | #else 1211 | s_save(OP_E1ARGS, NIL, cdr(code)); 1212 | #endif 1213 | code = car(code); 1214 | s_goto(OP_EVAL); 1215 | } 1216 | } else { 1217 | s_return(code); 1218 | } 1219 | 1220 | #ifdef USE_MACRO 1221 | case OP_E0ARGS: /* eval arguments */ 1222 | if (ismacro(value)) { /* macro expansion */ 1223 | s_save(OP_DOMACRO, NIL, NIL); 1224 | args = cons(code, NIL); 1225 | code = value; 1226 | s_goto(OP_APPLY); 1227 | } else { 1228 | code = cdr(code); 1229 | s_goto(OP_E1ARGS); 1230 | } 1231 | #endif 1232 | 1233 | case OP_E1ARGS: /* eval arguments */ 1234 | args = cons(value, args); 1235 | if (ispair(code)) { /* continue */ 1236 | s_save(OP_E1ARGS, args, cdr(code)); 1237 | code = car(code); 1238 | args = NIL; 1239 | s_goto(OP_EVAL); 1240 | } else { /* end */ 1241 | args = reverse(args); 1242 | code = car(args); 1243 | args = cdr(args); 1244 | s_goto(OP_APPLY); 1245 | } 1246 | 1247 | case OP_APPLY: /* apply 'code' to 'args' */ 1248 | if (isproc(code)) { 1249 | s_goto(procnum(code)); /* PROCEDURE */ 1250 | } else if (isclosure(code)) { /* CLOSURE */ 1251 | /* make environment */ 1252 | envir = cons(NIL, closure_env(code)); 1253 | for (x = car(closure_code(code)), y = args; 1254 | ispair(x); x = cdr(x), y = cdr(y)) { 1255 | if (y == NIL) { 1256 | Error_0("Few arguments"); 1257 | } else { 1258 | car(envir) = cons(cons(car(x), car(y)), car(envir)); 1259 | } 1260 | } 1261 | if (x == NIL) { 1262 | /*-- 1263 | * if (y != NIL) { 1264 | * Error_0("Many arguments"); 1265 | * } 1266 | */ 1267 | } else if (issymbol(x)) 1268 | car(envir) = cons(cons(x, y), car(envir)); 1269 | else { 1270 | Error_0("Syntax error in closure"); 1271 | } 1272 | code = cdr(closure_code(code)); 1273 | args = NIL; 1274 | s_goto(OP_BEGIN); 1275 | } else if (iscontinuation(code)) { /* CONTINUATION */ 1276 | dump = cont_dump(code); 1277 | s_return(args != NIL ? car(args) : NIL); 1278 | } else { 1279 | Error_0("Illegal function"); 1280 | } 1281 | 1282 | #ifdef USE_MACRO 1283 | case OP_DOMACRO: /* do macro */ 1284 | code = value; 1285 | s_goto(OP_EVAL); 1286 | #endif 1287 | 1288 | case OP_LAMBDA: /* lambda */ 1289 | s_return(mk_closure(code, envir)); 1290 | 1291 | case OP_QUOTE: /* quote */ 1292 | s_return(car(code)); 1293 | 1294 | case OP_DEF0: /* define */ 1295 | if (ispair(car(code))) { 1296 | x = caar(code); 1297 | code = cons(LAMBDA, cons(cdar(code), cdr(code))); 1298 | } else { 1299 | x = car(code); 1300 | code = cadr(code); 1301 | } 1302 | if (!issymbol(x)) { 1303 | Error_0("Variable is not symbol"); 1304 | } 1305 | s_save(OP_DEF1, NIL, x); 1306 | s_goto(OP_EVAL); 1307 | 1308 | case OP_DEF1: /* define */ 1309 | for (x = car(envir); x != NIL; x = cdr(x)) 1310 | if (caar(x) == code) 1311 | break; 1312 | if (x != NIL) 1313 | cdar(x) = value; 1314 | else 1315 | car(envir) = cons(cons(code, value), car(envir)); 1316 | s_return(code); 1317 | 1318 | case OP_SET0: /* set! */ 1319 | s_save(OP_SET1, NIL, car(code)); 1320 | code = cadr(code); 1321 | s_goto(OP_EVAL); 1322 | 1323 | case OP_SET1: /* set! */ 1324 | for (x = envir; x != NIL; x = cdr(x)) { 1325 | for (y = car(x); y != NIL; y = cdr(y)) 1326 | if (caar(y) == code) 1327 | break; 1328 | if (y != NIL) 1329 | break; 1330 | } 1331 | if (x != NIL) { 1332 | cdar(y) = value; 1333 | s_return(value); 1334 | } else { 1335 | Error_1("Unbounded variable", code); 1336 | } 1337 | 1338 | case OP_BEGIN: /* begin */ 1339 | if (!ispair(code)) { 1340 | s_return(code); 1341 | } 1342 | if (cdr(code) != NIL) { 1343 | s_save(OP_BEGIN, NIL, cdr(code)); 1344 | } 1345 | code = car(code); 1346 | s_goto(OP_EVAL); 1347 | 1348 | case OP_IF0: /* if */ 1349 | s_save(OP_IF1, NIL, cdr(code)); 1350 | code = car(code); 1351 | s_goto(OP_EVAL); 1352 | 1353 | case OP_IF1: /* if */ 1354 | if (istrue(value)) 1355 | code = car(code); 1356 | else 1357 | code = cadr(code); /* (if #f 1) ==> () because 1358 | * car(NIL) = NIL */ 1359 | s_goto(OP_EVAL); 1360 | 1361 | case OP_LET0: /* let */ 1362 | args = NIL; 1363 | value = code; 1364 | code = issymbol(car(code)) ? cadr(code) : car(code); 1365 | s_goto(OP_LET1); 1366 | 1367 | case OP_LET1: /* let (caluculate parameters) */ 1368 | args = cons(value, args); 1369 | if (ispair(code)) { /* continue */ 1370 | s_save(OP_LET1, args, cdr(code)); 1371 | code = cadar(code); 1372 | args = NIL; 1373 | s_goto(OP_EVAL); 1374 | } else { /* end */ 1375 | args = reverse(args); 1376 | code = car(args); 1377 | args = cdr(args); 1378 | s_goto(OP_LET2); 1379 | } 1380 | 1381 | case OP_LET2: /* let */ 1382 | envir = cons(NIL, envir); 1383 | for (x = issymbol(car(code)) ? cadr(code) : car(code), y = args; 1384 | y != NIL; x = cdr(x), y = cdr(y)) 1385 | car(envir) = cons(cons(caar(x), car(y)), car(envir)); 1386 | if (issymbol(car(code))) { /* named let */ 1387 | for (x = cadr(code), args = NIL; x != NIL; x = cdr(x)) 1388 | args = cons(caar(x), args); 1389 | x = mk_closure(cons(reverse(args), cddr(code)), envir); 1390 | car(envir) = cons(cons(car(code), x), car(envir)); 1391 | code = cddr(code); 1392 | args = NIL; 1393 | } else { 1394 | code = cdr(code); 1395 | args = NIL; 1396 | } 1397 | s_goto(OP_BEGIN); 1398 | 1399 | case OP_LET0AST: /* let* */ 1400 | if (car(code) == NIL) { 1401 | envir = cons(NIL, envir); 1402 | code = cdr(code); 1403 | s_goto(OP_BEGIN); 1404 | } 1405 | s_save(OP_LET1AST, cdr(code), car(code)); 1406 | code = cadaar(code); 1407 | s_goto(OP_EVAL); 1408 | 1409 | case OP_LET1AST: /* let* (make new frame) */ 1410 | envir = cons(NIL, envir); 1411 | s_goto(OP_LET2AST); 1412 | 1413 | case OP_LET2AST: /* let* (caluculate parameters) */ 1414 | car(envir) = cons(cons(caar(code), value), car(envir)); 1415 | code = cdr(code); 1416 | if (ispair(code)) { /* continue */ 1417 | s_save(OP_LET2AST, args, code); 1418 | code = cadar(code); 1419 | args = NIL; 1420 | s_goto(OP_EVAL); 1421 | } else { /* end */ 1422 | code = args; 1423 | args = NIL; 1424 | s_goto(OP_BEGIN); 1425 | } 1426 | default: 1427 | sprintf(strbuff, "%d is illegal operator", operator); 1428 | Error_0(strbuff); 1429 | } 1430 | return T; 1431 | } 1432 | 1433 | 1434 | pointer opexe_1(op) 1435 | register short op; 1436 | { 1437 | register pointer x, y; 1438 | 1439 | switch (op) { 1440 | case OP_LET0REC: /* letrec */ 1441 | envir = cons(NIL, envir); 1442 | args = NIL; 1443 | value = code; 1444 | code = car(code); 1445 | s_goto(OP_LET1REC); 1446 | 1447 | case OP_LET1REC: /* letrec (caluculate parameters) */ 1448 | args = cons(value, args); 1449 | if (ispair(code)) { /* continue */ 1450 | s_save(OP_LET1REC, args, cdr(code)); 1451 | code = cadar(code); 1452 | args = NIL; 1453 | s_goto(OP_EVAL); 1454 | } else { /* end */ 1455 | args = reverse(args); 1456 | code = car(args); 1457 | args = cdr(args); 1458 | s_goto(OP_LET2REC); 1459 | } 1460 | 1461 | case OP_LET2REC: /* letrec */ 1462 | for (x = car(code), y = args; y != NIL; x = cdr(x), y = cdr(y)) 1463 | car(envir) = cons(cons(caar(x), car(y)), car(envir)); 1464 | code = cdr(code); 1465 | args = NIL; 1466 | s_goto(OP_BEGIN); 1467 | 1468 | case OP_COND0: /* cond */ 1469 | if (!ispair(code)) { 1470 | Error_0("Syntax error in cond"); 1471 | } 1472 | s_save(OP_COND1, NIL, code); 1473 | code = caar(code); 1474 | s_goto(OP_EVAL); 1475 | 1476 | case OP_COND1: /* cond */ 1477 | if (istrue(value)) { 1478 | if ((code = cdar(code)) == NIL) { 1479 | s_return(value); 1480 | } 1481 | s_goto(OP_BEGIN); 1482 | } else { 1483 | if ((code = cdr(code)) == NIL) { 1484 | s_return(NIL); 1485 | } else { 1486 | s_save(OP_COND1, NIL, code); 1487 | code = caar(code); 1488 | s_goto(OP_EVAL); 1489 | } 1490 | } 1491 | 1492 | case OP_DELAY: /* delay */ 1493 | x = mk_closure(cons(NIL, code), envir); 1494 | setpromise(x); 1495 | s_return(x); 1496 | 1497 | case OP_AND0: /* and */ 1498 | if (code == NIL) { 1499 | s_return(T); 1500 | } 1501 | s_save(OP_AND1, NIL, cdr(code)); 1502 | code = car(code); 1503 | s_goto(OP_EVAL); 1504 | 1505 | case OP_AND1: /* and */ 1506 | if (isfalse(value)) { 1507 | s_return(value); 1508 | } else if (code == NIL) { 1509 | s_return(value); 1510 | } else { 1511 | s_save(OP_AND1, NIL, cdr(code)); 1512 | code = car(code); 1513 | s_goto(OP_EVAL); 1514 | } 1515 | 1516 | case OP_OR0: /* or */ 1517 | if (code == NIL) { 1518 | s_return(F); 1519 | } 1520 | s_save(OP_OR1, NIL, cdr(code)); 1521 | code = car(code); 1522 | s_goto(OP_EVAL); 1523 | 1524 | case OP_OR1: /* or */ 1525 | if (istrue(value)) { 1526 | s_return(value); 1527 | } else if (code == NIL) { 1528 | s_return(value); 1529 | } else { 1530 | s_save(OP_OR1, NIL, cdr(code)); 1531 | code = car(code); 1532 | s_goto(OP_EVAL); 1533 | } 1534 | 1535 | case OP_C0STREAM: /* cons-stream */ 1536 | s_save(OP_C1STREAM, NIL, cdr(code)); 1537 | code = car(code); 1538 | s_goto(OP_EVAL); 1539 | 1540 | case OP_C1STREAM: /* cons-stream */ 1541 | args = value; /* save value to register args for gc */ 1542 | x = mk_closure(cons(NIL, code), envir); 1543 | setpromise(x); 1544 | s_return(cons(args, x)); 1545 | 1546 | #ifdef USE_MACRO 1547 | case OP_0MACRO: /* macro */ 1548 | x = car(code); 1549 | code = cadr(code); 1550 | if (!issymbol(x)) { 1551 | Error_0("Variable is not symbol"); 1552 | } 1553 | s_save(OP_1MACRO, NIL, x); 1554 | s_goto(OP_EVAL); 1555 | 1556 | case OP_1MACRO: /* macro */ 1557 | type(value) |= T_MACRO; 1558 | for (x = car(envir); x != NIL; x = cdr(x)) 1559 | if (caar(x) == code) 1560 | break; 1561 | if (x != NIL) 1562 | cdar(x) = value; 1563 | else 1564 | car(envir) = cons(cons(code, value), car(envir)); 1565 | s_return(code); 1566 | #endif 1567 | 1568 | case OP_CASE0: /* case */ 1569 | s_save(OP_CASE1, NIL, cdr(code)); 1570 | code = car(code); 1571 | s_goto(OP_EVAL); 1572 | 1573 | case OP_CASE1: /* case */ 1574 | for (x = code; x != NIL; x = cdr(x)) { 1575 | if (!ispair(y = caar(x))) 1576 | break; 1577 | for ( ; y != NIL; y = cdr(y)) 1578 | if (eqv(car(y), value)) 1579 | break; 1580 | if (y != NIL) 1581 | break; 1582 | } 1583 | if (x != NIL) { 1584 | if (ispair(caar(x))) { 1585 | code = cdar(x); 1586 | s_goto(OP_BEGIN); 1587 | } else {/* else */ 1588 | s_save(OP_CASE2, NIL, cdar(x)); 1589 | code = caar(x); 1590 | s_goto(OP_EVAL); 1591 | } 1592 | } else { 1593 | s_return(NIL); 1594 | } 1595 | 1596 | case OP_CASE2: /* case */ 1597 | if (istrue(value)) { 1598 | s_goto(OP_BEGIN); 1599 | } else { 1600 | s_return(NIL); 1601 | } 1602 | case OP_PAPPLY: /* apply */ 1603 | code = car(args); 1604 | args = cadr(args); 1605 | s_goto(OP_APPLY); 1606 | 1607 | case OP_PEVAL: /* eval */ 1608 | code = car(args); 1609 | args = NIL; 1610 | s_goto(OP_EVAL); 1611 | 1612 | case OP_CONTINUATION: /* call-with-current-continuation */ 1613 | code = car(args); 1614 | args = cons(mk_continuation(dump), NIL); 1615 | s_goto(OP_APPLY); 1616 | 1617 | default: 1618 | sprintf(strbuff, "%d is illegal operator", operator); 1619 | Error_0(strbuff); 1620 | } 1621 | return T; 1622 | } 1623 | 1624 | 1625 | pointer opexe_2(op) 1626 | register short op; 1627 | { 1628 | register pointer x, y; 1629 | register long v; 1630 | 1631 | switch (op) { 1632 | case OP_ADD: /* + */ 1633 | for (x = args, v = 0; x != NIL; x = cdr(x)) 1634 | v += ivalue(car(x)); 1635 | s_return(mk_number(v)); 1636 | 1637 | case OP_SUB: /* - */ 1638 | for (x = cdr(args), v = ivalue(car(args)); x != NIL; x = cdr(x)) 1639 | v -= ivalue(car(x)); 1640 | s_return(mk_number(v)); 1641 | 1642 | case OP_MUL: /* * */ 1643 | for (x = args, v = 1; x != NIL; x = cdr(x)) 1644 | v *= ivalue(car(x)); 1645 | s_return(mk_number(v)); 1646 | 1647 | case OP_DIV: /* / */ 1648 | for (x = cdr(args), v = ivalue(car(args)); x != NIL; x = cdr(x)) { 1649 | if (ivalue(car(x)) != 0) 1650 | v /= ivalue(car(x)); 1651 | else { 1652 | Error_0("Divided by zero"); 1653 | } 1654 | } 1655 | s_return(mk_number(v)); 1656 | 1657 | case OP_REM: /* remainder */ 1658 | for (x = cdr(args), v = ivalue(car(args)); x != NIL; x = cdr(x)) { 1659 | if (ivalue(car(x)) != 0) 1660 | v %= ivalue(car(x)); 1661 | else { 1662 | Error_0("Divided by zero"); 1663 | } 1664 | } 1665 | s_return(mk_number(v)); 1666 | 1667 | case OP_CAR: /* car */ 1668 | if (ispair(car(args))) { 1669 | s_return(caar(args)); 1670 | } else { 1671 | Error_0("Unable to car for non-cons cell"); 1672 | } 1673 | 1674 | case OP_CDR: /* cdr */ 1675 | if (ispair(car(args))) { 1676 | s_return(cdar(args)); 1677 | } else { 1678 | Error_0("Unable to cdr for non-cons cell"); 1679 | } 1680 | 1681 | case OP_CONS: /* cons */ 1682 | cdr(args) = cadr(args); 1683 | s_return(args); 1684 | 1685 | case OP_SETCAR: /* set-car! */ 1686 | if (ispair(car(args))) { 1687 | caar(args) = cadr(args); 1688 | s_return(car(args)); 1689 | } else { 1690 | Error_0("Unable to set-car! for non-cons cell"); 1691 | } 1692 | 1693 | case OP_SETCDR: /* set-cdr! */ 1694 | if (ispair(car(args))) { 1695 | cdar(args) = cadr(args); 1696 | s_return(car(args)); 1697 | } else { 1698 | Error_0("Unable to set-cdr! for non-cons cell"); 1699 | } 1700 | 1701 | default: 1702 | sprintf(strbuff, "%d is illegal operator", operator); 1703 | Error_0(strbuff); 1704 | } 1705 | return T; 1706 | } 1707 | 1708 | 1709 | pointer opexe_3(op) 1710 | register short op; 1711 | { 1712 | register pointer x, y; 1713 | 1714 | switch (op) { 1715 | case OP_NOT: /* not */ 1716 | s_retbool(isfalse(car(args))); 1717 | case OP_BOOL: /* boolean? */ 1718 | s_retbool(car(args) == F || car(args) == T); 1719 | case OP_NULL: /* null? */ 1720 | s_retbool(car(args) == NIL); 1721 | case OP_ZEROP: /* zero? */ 1722 | s_retbool(ivalue(car(args)) == 0); 1723 | case OP_POSP: /* positive? */ 1724 | s_retbool(ivalue(car(args)) > 0); 1725 | case OP_NEGP: /* negative? */ 1726 | s_retbool(ivalue(car(args)) < 0); 1727 | case OP_NEQ: /* = */ 1728 | s_retbool(ivalue(car(args)) == ivalue(cadr(args))); 1729 | case OP_LESS: /* < */ 1730 | s_retbool(ivalue(car(args)) < ivalue(cadr(args))); 1731 | case OP_GRE: /* > */ 1732 | s_retbool(ivalue(car(args)) > ivalue(cadr(args))); 1733 | case OP_LEQ: /* <= */ 1734 | s_retbool(ivalue(car(args)) <= ivalue(cadr(args))); 1735 | case OP_GEQ: /* >= */ 1736 | s_retbool(ivalue(car(args)) >= ivalue(cadr(args))); 1737 | case OP_SYMBOL: /* symbol? */ 1738 | s_retbool(issymbol(car(args))); 1739 | case OP_NUMBER: /* number? */ 1740 | s_retbool(isnumber(car(args))); 1741 | case OP_STRING: /* string? */ 1742 | s_retbool(isstring(car(args))); 1743 | case OP_PROC: /* procedure? */ 1744 | /*-- 1745 | * continuation should be procedure by the example 1746 | * (call-with-current-continuation procedure?) ==> #t 1747 | * in R^3 report sec. 6.9 1748 | */ 1749 | s_retbool(isproc(car(args)) || isclosure(car(args)) 1750 | || iscontinuation(car(args))); 1751 | case OP_PAIR: /* pair? */ 1752 | s_retbool(ispair(car(args))); 1753 | case OP_EQ: /* eq? */ 1754 | s_retbool(car(args) == cadr(args)); 1755 | case OP_EQV: /* eqv? */ 1756 | s_retbool(eqv(car(args), cadr(args))); 1757 | default: 1758 | sprintf(strbuff, "%d is illegal operator", operator); 1759 | Error_0(strbuff); 1760 | } 1761 | return T; 1762 | } 1763 | 1764 | 1765 | pointer opexe_4(op) 1766 | register short op; 1767 | { 1768 | register pointer x, y; 1769 | 1770 | switch (op) { 1771 | case OP_FORCE: /* force */ 1772 | code = car(args); 1773 | if (ispromise(code)) { 1774 | args = NIL; 1775 | s_goto(OP_APPLY); 1776 | } else { 1777 | s_return(code); 1778 | } 1779 | 1780 | case OP_WRITE: /* write */ 1781 | print_flag = 1; 1782 | args = car(args); 1783 | s_goto(OP_P0LIST); 1784 | 1785 | case OP_DISPLAY: /* display */ 1786 | print_flag = 0; 1787 | args = car(args); 1788 | s_goto(OP_P0LIST); 1789 | 1790 | case OP_NEWLINE: /* newline */ 1791 | fprintf(outfp, "\n"); 1792 | s_return(T); 1793 | 1794 | case OP_ERR0: /* error */ 1795 | if (!isstring(car(args))) { 1796 | Error_0("error -- first argument must be string"); 1797 | } 1798 | tmpfp = outfp; 1799 | outfp = stderr; 1800 | if (all_errors_fatal) { 1801 | FatalError(strvalue(car(args))); 1802 | } 1803 | fprintf(outfp, "Error: "); 1804 | fprintf(outfp, "%s", strvalue(car(args))); 1805 | args = cdr(args); 1806 | s_goto(OP_ERR1); 1807 | 1808 | case OP_ERR1: /* error */ 1809 | fprintf(outfp, " "); 1810 | if (args != NIL) { 1811 | s_save(OP_ERR1, cdr(args), NIL); 1812 | args = car(args); 1813 | print_flag = 1; 1814 | s_goto(OP_P0LIST); 1815 | } else { 1816 | fprintf(outfp, "\n"); 1817 | flushinput(); 1818 | outfp = tmpfp; 1819 | s_goto(OP_T0LVL); 1820 | } 1821 | 1822 | case OP_REVERSE: /* reverse */ 1823 | s_return(reverse(car(args))); 1824 | 1825 | case OP_APPEND: /* append */ 1826 | s_return(append(car(args), cadr(args))); 1827 | 1828 | case OP_PUT: /* put */ 1829 | if (!hasprop(car(args)) || !hasprop(cadr(args))) { 1830 | Error_0("Illegal use of put"); 1831 | } 1832 | for (x = symprop(car(args)), y = cadr(args); x != NIL; x = cdr(x)) 1833 | if (caar(x) == y) 1834 | break; 1835 | if (x != NIL) 1836 | cdar(x) = caddr(args); 1837 | else 1838 | symprop(car(args)) = cons(cons(y, caddr(args)), 1839 | symprop(car(args))); 1840 | s_return(T); 1841 | 1842 | case OP_GET: /* get */ 1843 | if (!hasprop(car(args)) || !hasprop(cadr(args))) { 1844 | Error_0("Illegal use of get"); 1845 | } 1846 | for (x = symprop(car(args)), y = cadr(args); x != NIL; x = cdr(x)) 1847 | if (caar(x) == y) 1848 | break; 1849 | if (x != NIL) { 1850 | s_return(cdar(x)); 1851 | } else { 1852 | s_return(NIL); 1853 | } 1854 | 1855 | case OP_QUIT: /* quit */ 1856 | return (NIL); 1857 | 1858 | case OP_GC: /* gc */ 1859 | gc(NIL, NIL); 1860 | s_return(T); 1861 | 1862 | case OP_GCVERB: /* gc-verbose */ 1863 | { int was = gc_verbose; 1864 | 1865 | gc_verbose = (car(args) != F); 1866 | s_retbool(was); 1867 | } 1868 | 1869 | case OP_NEWSEGMENT: /* new-segment */ 1870 | if (!isnumber(car(args))) { 1871 | Error_0("new-segment -- argument must be number"); 1872 | } 1873 | fprintf(outfp, "allocate %d new segments\n", 1874 | alloc_cellseg((int) ivalue(car(args)))); 1875 | s_return(T); 1876 | } 1877 | } 1878 | 1879 | 1880 | pointer opexe_5(op) 1881 | register short op; 1882 | { 1883 | register pointer x, y; 1884 | 1885 | switch (op) { 1886 | /* ========== reading part ========== */ 1887 | case OP_RDSEXPR: 1888 | switch (tok) { 1889 | case TOK_COMMENT: 1890 | while (inchar() != '\n') 1891 | ; 1892 | tok = token(); 1893 | s_goto(OP_RDSEXPR); 1894 | case TOK_LPAREN: 1895 | tok = token(); 1896 | if (tok == TOK_RPAREN) { 1897 | s_return(NIL); 1898 | } else if (tok == TOK_DOT) { 1899 | Error_0("syntax error -- illegal dot expression"); 1900 | } else { 1901 | s_save(OP_RDLIST, NIL, NIL); 1902 | s_goto(OP_RDSEXPR); 1903 | } 1904 | case TOK_QUOTE: 1905 | s_save(OP_RDQUOTE, NIL, NIL); 1906 | tok = token(); 1907 | s_goto(OP_RDSEXPR); 1908 | #ifdef USE_QQUOTE 1909 | case TOK_BQUOTE: 1910 | s_save(OP_RDQQUOTE, NIL, NIL); 1911 | tok = token(); 1912 | s_goto(OP_RDSEXPR); 1913 | case TOK_COMMA: 1914 | s_save(OP_RDUNQUOTE, NIL, NIL); 1915 | tok = token(); 1916 | s_goto(OP_RDSEXPR); 1917 | case TOK_ATMARK: 1918 | s_save(OP_RDUQTSP, NIL, NIL); 1919 | tok = token(); 1920 | s_goto(OP_RDSEXPR); 1921 | #endif 1922 | case TOK_ATOM: 1923 | s_return(mk_atom(readstr("();\t\n "))); 1924 | case TOK_DQUOTE: 1925 | s_return(mk_string(readstrexp())); 1926 | case TOK_SHARP: 1927 | if ((x = mk_const(readstr("();\t\n "))) == NIL) { 1928 | Error_0("Undefined sharp expression"); 1929 | } else { 1930 | s_return(x); 1931 | } 1932 | default: 1933 | Error_0("syntax error -- illegal token"); 1934 | } 1935 | break; 1936 | 1937 | case OP_RDLIST: 1938 | args = cons(value, args); 1939 | tok = token(); 1940 | if (tok == TOK_COMMENT) { 1941 | while (inchar() != '\n') 1942 | ; 1943 | tok = token(); 1944 | } 1945 | if (tok == TOK_RPAREN) { 1946 | s_return(non_alloc_rev(NIL, args)); 1947 | } else if (tok == TOK_DOT) { 1948 | s_save(OP_RDDOT, args, NIL); 1949 | tok = token(); 1950 | s_goto(OP_RDSEXPR); 1951 | } else { 1952 | s_save(OP_RDLIST, args, NIL);; 1953 | s_goto(OP_RDSEXPR); 1954 | } 1955 | 1956 | case OP_RDDOT: 1957 | if (token() != TOK_RPAREN) { 1958 | Error_0("syntax error -- illegal dot expression"); 1959 | } else { 1960 | s_return(non_alloc_rev(value, args)); 1961 | } 1962 | 1963 | case OP_RDQUOTE: 1964 | s_return(cons(QUOTE, cons(value, NIL))); 1965 | 1966 | #ifdef USE_QQUOTE 1967 | case OP_RDQQUOTE: 1968 | s_return(cons(QQUOTE, cons(value, NIL))); 1969 | 1970 | case OP_RDUNQUOTE: 1971 | s_return(cons(UNQUOTE, cons(value, NIL))); 1972 | 1973 | case OP_RDUQTSP: 1974 | s_return(cons(UNQUOTESP, cons(value, NIL))); 1975 | #endif 1976 | 1977 | /* ========== printing part ========== */ 1978 | case OP_P0LIST: 1979 | if (!ispair(args)) { 1980 | printatom(args, print_flag); 1981 | s_return(T); 1982 | } else if (car(args) == QUOTE && ok_abbrev(cdr(args))) { 1983 | fprintf(outfp, "'"); 1984 | args = cadr(args); 1985 | s_goto(OP_P0LIST); 1986 | } else if (car(args) == QQUOTE && ok_abbrev(cdr(args))) { 1987 | fprintf(outfp, "`"); 1988 | args = cadr(args); 1989 | s_goto(OP_P0LIST); 1990 | } else if (car(args) == UNQUOTE && ok_abbrev(cdr(args))) { 1991 | fprintf(outfp, ","); 1992 | args = cadr(args); 1993 | s_goto(OP_P0LIST); 1994 | } else if (car(args) == UNQUOTESP && ok_abbrev(cdr(args))) { 1995 | fprintf(outfp, ",@"); 1996 | args = cadr(args); 1997 | s_goto(OP_P0LIST); 1998 | } else { 1999 | fprintf(outfp, "("); 2000 | s_save(OP_P1LIST, cdr(args), NIL); 2001 | args = car(args); 2002 | s_goto(OP_P0LIST); 2003 | } 2004 | 2005 | case OP_P1LIST: 2006 | if (ispair(args)) { 2007 | s_save(OP_P1LIST, cdr(args), NIL); 2008 | fprintf(outfp, " "); 2009 | args = car(args); 2010 | s_goto(OP_P0LIST); 2011 | } else { 2012 | if (args != NIL) { 2013 | fprintf(outfp, " . "); 2014 | printatom(args, print_flag); 2015 | } 2016 | fprintf(outfp, ")"); 2017 | s_return(T); 2018 | } 2019 | 2020 | default: 2021 | sprintf(strbuff, "%d is illegal operator", operator); 2022 | Error_0(strbuff); 2023 | 2024 | } 2025 | return T; 2026 | } 2027 | 2028 | 2029 | pointer opexe_6(op) 2030 | register short op; 2031 | { 2032 | register pointer x, y; 2033 | register long v; 2034 | static long w; 2035 | char buffer[32]; 2036 | 2037 | switch (op) { 2038 | case OP_LIST_LENGTH: /* list-length */ /* a.k */ 2039 | for (x = car(args), v = 0; ispair(x); x = cdr(x)) 2040 | ++v; 2041 | s_return(mk_number(v)); 2042 | 2043 | case OP_ASSQ: /* assq */ /* a.k */ 2044 | x = car(args); 2045 | for (y = cadr(args); ispair(y); y = cdr(y)) { 2046 | if (!ispair(car(y))) { 2047 | Error_0("Unable to handle non pair element"); 2048 | } 2049 | if (x == caar(y)) 2050 | break; 2051 | } 2052 | if (ispair(y)) { 2053 | s_return(car(y)); 2054 | } else { 2055 | s_return(F); 2056 | } 2057 | 2058 | case OP_PRINT_WIDTH: /* print-width */ /* a.k */ 2059 | w = 0; 2060 | args = car(args); 2061 | print_flag = -1; 2062 | s_goto(OP_P0_WIDTH); 2063 | 2064 | case OP_P0_WIDTH: 2065 | if (!ispair(args)) { 2066 | w += printatom(args, print_flag); 2067 | s_return(mk_number(w)); 2068 | } else if (car(args) == QUOTE 2069 | && ok_abbrev(cdr(args))) { 2070 | ++w; 2071 | args = cadr(args); 2072 | s_goto(OP_P0_WIDTH); 2073 | } else if (car(args) == QQUOTE 2074 | && ok_abbrev(cdr(args))) { 2075 | ++w; 2076 | args = cadr(args); 2077 | s_goto(OP_P0_WIDTH); 2078 | } else if (car(args) == UNQUOTE 2079 | && ok_abbrev(cdr(args))) { 2080 | ++w; 2081 | args = cadr(args); 2082 | s_goto(OP_P0_WIDTH); 2083 | } else if (car(args) == UNQUOTESP 2084 | && ok_abbrev(cdr(args))) { 2085 | w += 2; 2086 | args = cadr(args); 2087 | s_goto(OP_P0_WIDTH); 2088 | } else { 2089 | ++w; 2090 | s_save(OP_P1_WIDTH, cdr(args), NIL); 2091 | args = car(args); 2092 | s_goto(OP_P0_WIDTH); 2093 | } 2094 | 2095 | case OP_P1_WIDTH: 2096 | if (ispair(args)) { 2097 | s_save(OP_P1_WIDTH, cdr(args), NIL); 2098 | ++w; 2099 | args = car(args); 2100 | s_goto(OP_P0_WIDTH); 2101 | } else { 2102 | if (args != NIL) 2103 | w += 3 + printatom(args, print_flag); 2104 | ++w; 2105 | s_return(mk_number(w)); 2106 | } 2107 | 2108 | case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */ 2109 | args = car(args); 2110 | if (args == NIL) { 2111 | s_return(F); 2112 | } else if (isclosure(args)) { 2113 | s_return(cons(LAMBDA, closure_code(value))); 2114 | #ifdef USE_MACRO 2115 | } else if (ismacro(args)) { 2116 | s_return(cons(LAMBDA, closure_code(value))); 2117 | #endif 2118 | } else { 2119 | s_return(F); 2120 | } 2121 | case OP_CLOSUREP: /* closure? */ 2122 | /* 2123 | * Note, macro object is also a closure. 2124 | * Therefore, (closure? <#MACRO>) ==> #t 2125 | */ 2126 | if (car(args) == NIL) { 2127 | s_return(F); 2128 | } 2129 | s_retbool(isclosure(car(args))); 2130 | #ifdef USE_MACRO 2131 | case OP_MACROP: /* macro? */ 2132 | if (car(args) == NIL) { 2133 | s_return(F); 2134 | } 2135 | s_retbool(ismacro(car(args))); 2136 | #endif 2137 | default: 2138 | sprintf(strbuff, "%d is illegal operator", operator); 2139 | Error_0(strbuff); 2140 | } 2141 | return T; /* NOTREACHED */ 2142 | } 2143 | 2144 | 2145 | 2146 | 2147 | pointer (*dispatch_table[])() = { 2148 | opexe_0, /* OP_LOAD = 0, */ 2149 | opexe_0, /* OP_T0LVL, */ 2150 | opexe_0, /* OP_T1LVL, */ 2151 | opexe_0, /* OP_READ, */ 2152 | opexe_0, /* OP_VALUEPRINT, */ 2153 | opexe_0, /* OP_EVAL, */ 2154 | opexe_0, /* OP_E0ARGS, */ 2155 | opexe_0, /* OP_E1ARGS, */ 2156 | opexe_0, /* OP_APPLY, */ 2157 | opexe_0, /* OP_DOMACRO, */ 2158 | 2159 | opexe_0, /* OP_LAMBDA, */ 2160 | opexe_0, /* OP_QUOTE, */ 2161 | opexe_0, /* OP_DEF0, */ 2162 | opexe_0, /* OP_DEF1, */ 2163 | opexe_0, /* OP_BEGIN, */ 2164 | opexe_0, /* OP_IF0, */ 2165 | opexe_0, /* OP_IF1, */ 2166 | opexe_0, /* OP_SET0, */ 2167 | opexe_0, /* OP_SET1, */ 2168 | opexe_0, /* OP_LET0, */ 2169 | opexe_0, /* OP_LET1, */ 2170 | opexe_0, /* OP_LET2, */ 2171 | opexe_0, /* OP_LET0AST, */ 2172 | opexe_0, /* OP_LET1AST, */ 2173 | opexe_0, /* OP_LET2AST, */ 2174 | 2175 | opexe_1, /* OP_LET0REC, */ 2176 | opexe_1, /* OP_LET1REC, */ 2177 | opexe_1, /* OP_LETREC2, */ 2178 | opexe_1, /* OP_COND0, */ 2179 | opexe_1, /* OP_COND1, */ 2180 | opexe_1, /* OP_DELAY, */ 2181 | opexe_1, /* OP_AND0, */ 2182 | opexe_1, /* OP_AND1, */ 2183 | opexe_1, /* OP_OR0, */ 2184 | opexe_1, /* OP_OR1, */ 2185 | opexe_1, /* OP_C0STREAM, */ 2186 | opexe_1, /* OP_C1STREAM, */ 2187 | opexe_1, /* OP_0MACRO, */ 2188 | opexe_1, /* OP_1MACRO, */ 2189 | opexe_1, /* OP_CASE0, */ 2190 | opexe_1, /* OP_CASE1, */ 2191 | opexe_1, /* OP_CASE2, */ 2192 | 2193 | opexe_1, /* OP_PEVAL, */ 2194 | opexe_1, /* OP_PAPPLY, */ 2195 | opexe_1, /* OP_CONTINUATION, */ 2196 | 2197 | opexe_2, /* OP_ADD, */ 2198 | opexe_2, /* OP_SUB, */ 2199 | opexe_2, /* OP_MUL, */ 2200 | opexe_2, /* OP_DIV, */ 2201 | opexe_2, /* OP_REM, */ 2202 | opexe_2, /* OP_CAR, */ 2203 | opexe_2, /* OP_CDR, */ 2204 | opexe_2, /* OP_CONS, */ 2205 | opexe_2, /* OP_SETCAR, */ 2206 | opexe_2, /* OP_SETCDR, */ 2207 | 2208 | opexe_3, /* OP_NOT, */ 2209 | opexe_3, /* OP_BOOL, */ 2210 | opexe_3, /* OP_NULL, */ 2211 | opexe_3, /* OP_ZEROP, */ 2212 | opexe_3, /* OP_POSP, */ 2213 | opexe_3, /* OP_NEGP, */ 2214 | opexe_3, /* OP_NEQ, */ 2215 | opexe_3, /* OP_LESS, */ 2216 | opexe_3, /* OP_GRE, */ 2217 | opexe_3, /* OP_LEQ, */ 2218 | opexe_3, /* OP_GEQ, */ 2219 | opexe_3, /* OP_SYMBOL, */ 2220 | opexe_3, /* OP_NUMBER, */ 2221 | opexe_3, /* OP_STRING, */ 2222 | opexe_3, /* OP_PROC, */ 2223 | opexe_3, /* OP_PAIR, */ 2224 | opexe_3, /* OP_EQ, */ 2225 | opexe_3, /* OP_EQV, */ 2226 | 2227 | opexe_4, /* OP_FORCE, */ 2228 | opexe_4, /* OP_WRITE, */ 2229 | opexe_4, /* OP_DISPLAY, */ 2230 | opexe_4, /* OP_NEWLINE, */ 2231 | opexe_4, /* OP_ERR0, */ 2232 | opexe_4, /* OP_ERR1, */ 2233 | opexe_4, /* OP_REVERSE, */ 2234 | opexe_4, /* OP_APPEND, */ 2235 | opexe_4, /* OP_PUT, */ 2236 | opexe_4, /* OP_GET, */ 2237 | opexe_4, /* OP_QUIT, */ 2238 | opexe_4, /* OP_GC, */ 2239 | opexe_4, /* OP_GCVERB, */ 2240 | opexe_4, /* OP_NEWSEGMENT, */ 2241 | 2242 | opexe_5, /* OP_RDSEXPR, */ 2243 | opexe_5, /* OP_RDLIST, */ 2244 | opexe_5, /* OP_RDDOT, */ 2245 | opexe_5, /* OP_RDQUOTE, */ 2246 | opexe_5, /* OP_RDQQUOTE, */ 2247 | opexe_5, /* OP_RDUNQUOTE, */ 2248 | opexe_5, /* OP_RDUQTSP, */ 2249 | opexe_5, /* OP_P0LIST, */ 2250 | opexe_5, /* OP_P1LIST, */ 2251 | 2252 | opexe_6, /* OP_LIST_LENGTH, */ 2253 | opexe_6, /* OP_ASSQ, */ 2254 | opexe_6, /* OP_PRINT_WIDTH, */ 2255 | opexe_6, /* OP_P0_WIDTH, */ 2256 | opexe_6, /* OP_P1_WIDTH, */ 2257 | opexe_6, /* OP_GET_CLOSURE, */ 2258 | opexe_6, /* OP_CLOSUREP, */ 2259 | #ifdef USE_MACRO 2260 | opexe_6, /* OP_MACROP, */ 2261 | #endif 2262 | 2263 | }; 2264 | 2265 | 2266 | /* kernel of this intepreter */ 2267 | pointer Eval_Cycle(op) 2268 | register short op; 2269 | { 2270 | 2271 | operator = op; 2272 | for (;;) 2273 | if ((*dispatch_table[operator])(operator) == NIL) 2274 | return NIL; 2275 | } 2276 | 2277 | /* ========== Initialization of internal keywords ========== */ 2278 | 2279 | mk_syntax(op, name) 2280 | unsigned short op; 2281 | char *name; 2282 | { 2283 | pointer x; 2284 | 2285 | x = cons(mk_string(name), NIL); 2286 | type(x) = (T_SYNTAX | T_SYMBOL); 2287 | syntaxnum(x) = op; 2288 | oblist = cons(x, oblist); 2289 | } 2290 | 2291 | mk_proc(op, name) 2292 | unsigned short op; 2293 | char *name; 2294 | { 2295 | pointer x, y; 2296 | 2297 | x = mk_symbol(name); 2298 | y = get_cell(NIL, NIL); 2299 | type(y) = (T_PROC | T_ATOM); 2300 | ivalue(y) = (long) op; 2301 | car(global_env) = cons(cons(x, y), car(global_env)); 2302 | } 2303 | 2304 | 2305 | init_vars_global() 2306 | { 2307 | pointer x; 2308 | 2309 | /* init input/output file */ 2310 | infp = stdin; 2311 | outfp = stdout; 2312 | /* init NIL */ 2313 | type(NIL) = (T_ATOM | MARK); 2314 | car(NIL) = cdr(NIL) = NIL; 2315 | /* init T */ 2316 | type(T) = (T_ATOM | MARK); 2317 | car(T) = cdr(T) = T; 2318 | /* init F */ 2319 | type(F) = (T_ATOM | MARK); 2320 | car(F) = cdr(F) = F; 2321 | /* init global_env */ 2322 | global_env = cons(NIL, NIL); 2323 | /* init else */ 2324 | x = mk_symbol("else"); 2325 | car(global_env) = cons(cons(x, T), car(global_env)); 2326 | } 2327 | 2328 | 2329 | init_syntax() 2330 | { 2331 | /* init syntax */ 2332 | mk_syntax(OP_LAMBDA, "lambda"); 2333 | mk_syntax(OP_QUOTE, "quote"); 2334 | mk_syntax(OP_DEF0, "define"); 2335 | mk_syntax(OP_IF0, "if"); 2336 | mk_syntax(OP_BEGIN, "begin"); 2337 | mk_syntax(OP_SET0, "set!"); 2338 | mk_syntax(OP_LET0, "let"); 2339 | mk_syntax(OP_LET0AST, "let*"); 2340 | mk_syntax(OP_LET0REC, "letrec"); 2341 | mk_syntax(OP_COND0, "cond"); 2342 | mk_syntax(OP_DELAY, "delay"); 2343 | mk_syntax(OP_AND0, "and"); 2344 | mk_syntax(OP_OR0, "or"); 2345 | mk_syntax(OP_C0STREAM, "cons-stream"); 2346 | #ifdef USE_MACRO 2347 | mk_syntax(OP_0MACRO, "macro"); 2348 | #endif 2349 | mk_syntax(OP_CASE0, "case"); 2350 | } 2351 | 2352 | 2353 | init_procs() 2354 | { 2355 | /* init procedure */ 2356 | mk_proc(OP_PEVAL, "eval"); 2357 | mk_proc(OP_PAPPLY, "apply"); 2358 | mk_proc(OP_CONTINUATION, "call-with-current-continuation"); 2359 | mk_proc(OP_FORCE, "force"); 2360 | mk_proc(OP_CAR, "car"); 2361 | mk_proc(OP_CDR, "cdr"); 2362 | mk_proc(OP_CONS, "cons"); 2363 | mk_proc(OP_SETCAR, "set-car!"); 2364 | mk_proc(OP_SETCDR, "set-cdr!"); 2365 | mk_proc(OP_ADD, "+"); 2366 | mk_proc(OP_SUB, "-"); 2367 | mk_proc(OP_MUL, "*"); 2368 | mk_proc(OP_DIV, "/"); 2369 | mk_proc(OP_REM, "remainder"); 2370 | mk_proc(OP_NOT, "not"); 2371 | mk_proc(OP_BOOL, "boolean?"); 2372 | mk_proc(OP_SYMBOL, "symbol?"); 2373 | mk_proc(OP_NUMBER, "number?"); 2374 | mk_proc(OP_STRING, "string?"); 2375 | mk_proc(OP_PROC, "procedure?"); 2376 | mk_proc(OP_PAIR, "pair?"); 2377 | mk_proc(OP_EQV, "eqv?"); 2378 | mk_proc(OP_EQ, "eq?"); 2379 | mk_proc(OP_NULL, "null?"); 2380 | mk_proc(OP_ZEROP, "zero?"); 2381 | mk_proc(OP_POSP, "positive?"); 2382 | mk_proc(OP_NEGP, "negative?"); 2383 | mk_proc(OP_NEQ, "="); 2384 | mk_proc(OP_LESS, "<"); 2385 | mk_proc(OP_GRE, ">"); 2386 | mk_proc(OP_LEQ, "<="); 2387 | mk_proc(OP_GEQ, ">="); 2388 | mk_proc(OP_READ, "read"); 2389 | mk_proc(OP_WRITE, "write"); 2390 | mk_proc(OP_DISPLAY, "display"); 2391 | mk_proc(OP_NEWLINE, "newline"); 2392 | mk_proc(OP_LOAD, "load"); 2393 | mk_proc(OP_ERR0, "error"); 2394 | mk_proc(OP_REVERSE, "reverse"); 2395 | mk_proc(OP_APPEND, "append"); 2396 | mk_proc(OP_PUT, "put"); 2397 | mk_proc(OP_GET, "get"); 2398 | mk_proc(OP_GC, "gc"); 2399 | mk_proc(OP_GCVERB, "gc-verbose"); 2400 | mk_proc(OP_NEWSEGMENT, "new-segment"); 2401 | mk_proc(OP_LIST_LENGTH, "list-length"); /* a.k */ 2402 | mk_proc(OP_ASSQ, "assq"); /* a.k */ 2403 | mk_proc(OP_PRINT_WIDTH, "print-width"); /* a.k */ 2404 | mk_proc(OP_GET_CLOSURE, "get-closure-code"); /* a.k */ 2405 | mk_proc(OP_CLOSUREP, "closure?"); /* a.k */ 2406 | #ifdef USE_MACRO 2407 | mk_proc(OP_MACROP, "macro?"); /* a.k */ 2408 | #endif 2409 | mk_proc(OP_QUIT, "quit"); 2410 | } 2411 | 2412 | 2413 | /* initialize several globals */ 2414 | init_globals() 2415 | { 2416 | init_vars_global(); 2417 | init_syntax(); 2418 | init_procs(); 2419 | /* intialization of global pointers to special symbols */ 2420 | LAMBDA = mk_symbol("lambda"); 2421 | QUOTE = mk_symbol("quote"); 2422 | #ifdef USE_QQUOTE 2423 | QQUOTE = mk_symbol("quasiquote"); 2424 | UNQUOTE = mk_symbol("unquote"); 2425 | UNQUOTESP = mk_symbol("unquote-splicing"); 2426 | #endif 2427 | 2428 | } 2429 | 2430 | /* ========== Error ========== */ 2431 | 2432 | FatalError(fmt, a, b, c) 2433 | char *fmt, *a, *b, *c; 2434 | { 2435 | fprintf(stderr, "Fatal error: "); 2436 | fprintf(stderr, fmt, a, b, c); 2437 | fprintf(stderr, "\n"); 2438 | exit(1); 2439 | } 2440 | 2441 | #ifdef USE_SETJMP 2442 | Error(fmt, a, b, c) 2443 | char *fmt, *a, *b, *c; 2444 | { 2445 | fprintf(stderr, "Error: "); 2446 | fprintf(stderr, fmt, a, b, c); 2447 | fprintf(stderr, "\n"); 2448 | flushinput(); 2449 | longjmp(error_jmp, OP_T0LVL); 2450 | } 2451 | 2452 | #endif 2453 | 2454 | /* ========== Main ========== */ 2455 | 2456 | #ifdef CMDLINE 2457 | main(argc, argv) 2458 | int argc; 2459 | char **argv; 2460 | #else 2461 | main() 2462 | #endif 2463 | { 2464 | short i; 2465 | short op = (short) OP_LOAD; 2466 | 2467 | #ifdef CMDLINE 2468 | for (i = 1; i < argc; i++) { 2469 | if (strcmp(argv[i], "-e") == 0) { 2470 | all_errors_fatal = 1; 2471 | } else if (strcmp(argv[i], "-q") == 0) { 2472 | quiet = 1; 2473 | } 2474 | } 2475 | #endif 2476 | 2477 | if (!quiet) 2478 | printf(banner); 2479 | init_scheme(); 2480 | args = cons(mk_string(InitFile), NIL); 2481 | #ifdef USE_SETJMP 2482 | op = setjmp(error_jmp); 2483 | #endif 2484 | Eval_Cycle(op); 2485 | exit(0); 2486 | } 2487 | 2488 | -------------------------------------------------------------------------------- /nextleaf.scm: -------------------------------------------------------------------------------- 1 | ;;;; Sample of co-routine by call/cc 2 | (define (apply-to-next-leaf proc tree endmark) 3 | (letrec 4 | ((return #f) 5 | (cont (lambda (l) 6 | (recurse l) 7 | (set! cont (lambda (d) (return endmark))) 8 | (cont #f))) 9 | (recurse (lambda (l) 10 | (if (pair? l) 11 | (for-each recurse l) 12 | (call/cc (lambda (c) (set! cont c) (return (proc l)))))))) 13 | (lambda () 14 | (call/cc (lambda (c) (set! return c) (cont tree)))))) 15 | 16 | (define (foo lis) 17 | (let ((bar (apply-to-next-leaf (lambda (x) (* x x)) lis '()))) 18 | (let loop ((n (bar))) 19 | (if (not (null? n)) 20 | (begin 21 | (display n) 22 | (newline) 23 | (loop (bar))))))) 24 | 25 | ;; foo prints each elements (leaves) squared 26 | (foo '(1 2 (3 (4 5) (6 (7)) 8) 9 10)) 27 | 28 | -------------------------------------------------------------------------------- /tools.scm: -------------------------------------------------------------------------------- 1 | ;;;; A Very Tiny Pretty Printer (VtPP) for Mini-Scheme 2 | ;;; 3 | ;;; Date written 28-Nov-1989 by Akira Kida 4 | ;;; Date revised 24-Jan-1990 by Atsushi Moriwaki 5 | ;;; Date revised 17-May-1994 by Akira Kida 6 | ;;; 7 | 8 | ;; Columns of display device. 9 | (define *pp-display-width* 80) 10 | 11 | ;; Margin of display-width 12 | ;; 8 means 80% of *pp-display-width*, i.e., if *pp-display-width* is 13 | ;; set to 80, the result is 64. The prety-print procedure will watch 14 | ;; for the current output column, and if the output seem to exceed 15 | ;; this limit, it tries to insert newlines somewhere in the current 16 | ;; sub-list. However, sometimes this may fail, and output may get even 17 | ;; longer than *pp-display-width*. This is a feature, not a bug. :-) 18 | (define *pp-display-margin* 8) 19 | 20 | ;; Number of elements will possibly be displayed in one line. 21 | ;; pretty-print will never display more then this number of elements 22 | ;; on a single physical line. There is no feature around this. :-) 23 | (define *pp-display-elements* 12) 24 | 25 | 26 | ;;; print n spaces 27 | (define (spaces n) 28 | (if (positive? n) 29 | (begin 30 | (display " ") 31 | (spaces (- n 1))))) 32 | 33 | 34 | ;;; get definition of a procedure or a macro 35 | (define (getd symbol) 36 | (if (not (symbol? symbol)) 37 | (error "getd: expects symbol value")) 38 | (let ((code (eval symbol))) 39 | (cond 40 | ;; since a closure is also a macro, we should check macro first. 41 | ((macro? code) 42 | (let ((def (get-closure-code code))) 43 | (cons 'macro (list symbol def)))) 44 | ((closure? code) 45 | (let ((def (get-closure-code code))) 46 | (cons 47 | 'define 48 | (cons 49 | (cons symbol (car (cdr def))) 50 | (cdr (cdr def)))))) 51 | (else 52 | ;; if symbol is not a macro nor closure, 53 | ;; we shall generate error function call code. 54 | (list 'error "Not a S-Expression procedure:" (list 'quote symbol)))))) 55 | 56 | 57 | ;;; pretty printer main procedure 58 | ;;; 59 | (define (pretty-print a-list) 60 | ; List of procedures which need exceptional handling. 61 | ; Structure or each element in the list is 62 | ; 63 | ; (name . special-indentation) 64 | ; 65 | ; where name is a symbol and 66 | ; special-indentation is an integer. 67 | ; 68 | ; #1 Standard format, non special case. 69 | ; (proc 70 | ; arg1 71 | ; arg2 72 | ; arg3) 73 | ; 74 | ; #2 Format for special-indentation == 0 75 | ; (proc arg1 76 | ; arg2 77 | ; arg3) 78 | ; 79 | ; #3 Format for special-indentation == 1 80 | ; (proc arg1 81 | ; arg2 82 | ; arg3) 83 | ; 84 | ; #4 Format for let style = 2 85 | ; (let ((x .....) 86 | ; (y .....)) 87 | ; <....> 88 | ; <....>) 89 | ; 90 | (define exception 91 | '((lambda . 0) (if . 0) (and . 1) 92 | (or . 1) (let . 2) (case . 0) 93 | (define . 0) (macro . 0) 94 | (map . 0) (apply . 0) 95 | (eq? . 1) (eqv? . 1) (set! . 0) 96 | (let* . 2) (letrec . 2) 97 | (* . 1) (/ . 1) (+ . 1) (- . 1) 98 | (= . 1) (< . 1) (> . 1) (<= . 1) (>= . 1) 99 | (do . 2) 100 | (call-with-input-file . 0) (call-with-output-file . 0))) 101 | ; special quote abbrev. 102 | (define special 103 | '((quote 1 . "'") (quasiquote 1 . "`") 104 | (unquote 2 . ",") (unquote-splicing 2 . ",@"))) 105 | ; calculate appropriate margins 106 | (define pp-margin (/ (* *pp-display-width* *pp-display-margin*) 10)) 107 | ; check whether the number of elements exceeds n or not. 108 | (define (less-than-n-elements? a-list n) 109 | ; count elements in a-list at most (n+1) 110 | (define (up-to-nth a-list n c) 111 | (cond 112 | ((null? a-list) c) 113 | ((pair? a-list) 114 | (set! c (up-to-nth (car a-list) n c)) 115 | (if (< n c) 116 | c 117 | (up-to-nth (cdr a-list) n c))) 118 | (else (+ c 1)))) 119 | (< (up-to-nth a-list n 0) n)) 120 | ; check if the length is fit within n columns or not. 121 | (define (fit-in-n-width? a-list n) 122 | (< (print-width a-list) n)) 123 | ; indent and pretty-print 124 | (define (do-pp a-list col) 125 | (spaces col) 126 | (pp-list a-list col 2)) 127 | ;; main logic. 128 | (define (pp-list a-list col step) 129 | (cond 130 | ((atom? a-list) (write a-list)) ; atom 131 | ((and (assq (car a-list) special) 132 | (pair? (cdr a-list)) 133 | (null? (cddr a-list))) ; check for proper quote etc. 134 | (let ((s (assq (car a-list) special))) 135 | (display (cddr s)) ; display using abbrev. 136 | (pp-list 137 | (cadr a-list) 138 | (+ col (- (print-width (cddr s)) 2)) 139 | (cadr s)))) 140 | ((and (less-than-n-elements? a-list *pp-display-elements*) 141 | (fit-in-n-width? a-list (- pp-margin col))) 142 | (display "(") 143 | (do-pp (car a-list) 0) 144 | (pp-args #f (cdr a-list) 1)) 145 | (else ; long list. 146 | (let* ((sym (car a-list)) 147 | (ex-col (assq sym exception))) 148 | (if (pair? ex-col) ; check for exception., 149 | (case (cdr ex-col) 150 | ((0 1) 151 | (display "(") 152 | (write sym) 153 | (display " ") 154 | (pp-list (cadr a-list) (+ col 2 (print-width sym)) 2) 155 | (pp-args 156 | #t 157 | (cdr (cdr a-list)) 158 | (+ col 2 (if (zero? (cdr ex-col)) 0 (print-width sym))))) 159 | ((2) 160 | (display "(") 161 | (write sym) 162 | (display " ") 163 | (if (symbol? (cadr a-list)) 164 | (begin ; named let 165 | (write (cadr a-list)) 166 | (display " ") 167 | (pp-list 168 | (caddr a-list) 169 | (+ col 3 (print-width sym) (print-width (cadr a-list))) 170 | 1) 171 | (pp-args #t (cdddr a-list) (+ col 2))) 172 | (begin ; usual let 173 | (pp-list (cadr a-list) (+ col 2 (print-width sym)) 1) 174 | (pp-args #t (cddr a-list) (+ col 2))))) 175 | (else 176 | (error "Illegal exception"))) 177 | (begin ; normal case. 178 | (display "(") 179 | (pp-list (car a-list) (+ col 1) 2) 180 | (pp-args #t (cdr a-list) (+ col step)))))))) 181 | ;; display arguments 182 | (define (pp-args nl a-list col) 183 | (cond 184 | ((null? a-list) (display ")")) 185 | ((pair? a-list) 186 | (if nl (newline)) 187 | (do-pp (car a-list) col) 188 | (pp-args nl (cdr a-list) col)) 189 | (else 190 | (display " . ") 191 | (write a-list) 192 | (display ")")))) 193 | ;; 194 | ;; main of pretty-print begins here. 195 | ;; 196 | (do-pp a-list 0) 197 | (newline)) 198 | 199 | 200 | 201 | ;;; pretty print procedure(s)/macro(s). 202 | ;;; (pretty 'a-symbol) ; pretty print a procedure or macro 203 | ;;; (pretty '(sym1 sym2 ...)) ; pretty print procedures and/or macros 204 | (define (pretty symbols) 205 | (if (pair? symbols) 206 | (for-each 207 | (lambda (x) (pretty-print (getd x)) (newline)) 208 | symbols) 209 | (pretty-print (getd symbols)))) 210 | 211 | 212 | 213 | ;;; pretty print user-interface 214 | ;;; 215 | ;;; usage: 216 | ;;; (pp sym1 sym2 ...) ; obtain procedure/macro definitions in sequence 217 | ;;; 218 | ;;; Note: pp never evaluate its argument, so you do not have to specify 219 | ;;; (pp 'proc-name). Use (pp proc-name) instead. 220 | ;;; 221 | (macro pp (lambda (pp-macro) 222 | `(pretty ',(cdr pp-macro)))) 223 | 224 | --------------------------------------------------------------------------------