diff options
Diffstat (limited to 'debian/patches/bootshell0004-bootshell-import-TinyScheme-1.41.patch')
| -rw-r--r-- | debian/patches/bootshell0004-bootshell-import-TinyScheme-1.41.patch | 7336 |
1 files changed, 7336 insertions, 0 deletions
diff --git a/debian/patches/bootshell0004-bootshell-import-TinyScheme-1.41.patch b/debian/patches/bootshell0004-bootshell-import-TinyScheme-1.41.patch new file mode 100644 index 00000000..0891c5e7 --- /dev/null +++ b/debian/patches/bootshell0004-bootshell-import-TinyScheme-1.41.patch @@ -0,0 +1,7336 @@ +From 2bf2dab79ccd3f39a1f9d72b58e639c26ff91a04 Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Sat, 24 Jan 2015 01:52:58 +0100 +Subject: [PATCH hurd 04/11] bootshell: import TinyScheme 1.41 + +This is a verbatim import of TinyScheme 1.41. + +* bootshell/COPYING.tinyscheme: New file. +* bootshell/Manual.txt: Likewise. +* bootshell/MiniSCHEMETribute.txt: Likewise. +* bootshell/hack.txt: Likewise. +* bootshell/init.scm: Likewise. +* bootshell/opdefines.h: Likewise. +* bootshell/scheme-private.h: Likewise. +* bootshell/scheme.c: Likewise. +* bootshell/scheme.h: Likewise. +--- + bootshell/COPYING.tinyscheme | 31 + + bootshell/Manual.txt | 452 ++++ + bootshell/MiniSCHEMETribute.txt | 88 + + bootshell/hack.txt | 244 ++ + bootshell/init.scm | 716 ++++++ + bootshell/opdefines.h | 195 ++ + bootshell/scheme-private.h | 210 ++ + bootshell/scheme.c | 5051 +++++++++++++++++++++++++++++++++++++++ + bootshell/scheme.h | 255 ++ + 9 files changed, 7242 insertions(+) + create mode 100644 bootshell/COPYING.tinyscheme + create mode 100644 bootshell/Manual.txt + create mode 100644 bootshell/MiniSCHEMETribute.txt + create mode 100644 bootshell/hack.txt + create mode 100644 bootshell/init.scm + create mode 100644 bootshell/opdefines.h + create mode 100644 bootshell/scheme-private.h + create mode 100644 bootshell/scheme.c + create mode 100644 bootshell/scheme.h + +diff --git a/bootshell/COPYING.tinyscheme b/bootshell/COPYING.tinyscheme +new file mode 100644 +index 0000000..a6c49a2 +--- /dev/null ++++ b/bootshell/COPYING.tinyscheme +@@ -0,0 +1,31 @@ ++ LICENSE TERMS ++ ++Copyright (c) 2000, Dimitrios Souflis ++All rights reserved. ++ ++Redistribution and use in source and binary forms, with or without ++modification, are permitted provided that the following conditions are ++met: ++ ++Redistributions of source code must retain the above copyright notice, ++this list of conditions and the following disclaimer. ++ ++Redistributions in binary form must reproduce the above copyright ++notice, this list of conditions and the following disclaimer in the ++documentation and/or other materials provided with the distribution. ++ ++Neither the name of Dimitrios Souflis nor the names of the ++contributors may be used to endorse or promote products derived from ++this software without specific prior written permission. ++ ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ++``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ++LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ++A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR ++CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ++EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ++PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ++PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ++LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ++NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ++SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +diff --git a/bootshell/Manual.txt b/bootshell/Manual.txt +new file mode 100644 +index 0000000..bf0e8ea +--- /dev/null ++++ b/bootshell/Manual.txt +@@ -0,0 +1,452 @@ ++ ++ ++ TinySCHEME Version 1.41 ++ ++ "Safe if used as prescribed" ++ -- Philip K. Dick, "Ubik" ++ ++This software is open source, covered by a BSD-style license. ++Please read accompanying file COPYING. ++------------------------------------------------------------------------------- ++ ++ This Scheme interpreter is based on MiniSCHEME version 0.85k4 ++ (see miniscm.tar.gz in the Scheme Repository) ++ Original credits in file MiniSCHEMETribute.txt. ++ ++ D. Souflis (dsouflis@acm.org) ++ ++------------------------------------------------------------------------------- ++ What is TinyScheme? ++ ------------------- ++ ++ TinyScheme is a lightweight Scheme interpreter that implements as large ++ a subset of R5RS as was possible without getting very large and ++ complicated. It is meant to be used as an embedded scripting interpreter ++ for other programs. As such, it does not offer IDEs or extensive toolkits ++ although it does sport a small top-level loop, included conditionally. ++ A lot of functionality in TinyScheme is included conditionally, to allow ++ developers freedom in balancing features and footprint. ++ ++ As an embedded interpreter, it allows multiple interpreter states to ++ coexist in the same program, without any interference between them. ++ Programmatically, foreign functions in C can be added and values ++ can be defined in the Scheme environment. Being a quite small program, ++ it is easy to comprehend, get to grips with, and use. ++ ++ Known bugs ++ ---------- ++ ++ TinyScheme is known to misbehave when memory is exhausted. ++ ++ ++ Things that keep missing, or that need fixing ++ --------------------------------------------- ++ ++ There are no hygienic macros. No rational or ++ complex numbers. No unwind-protect and call-with-values. ++ ++ Maybe (a subset of) SLIB will work with TinySCHEME... ++ ++ Decent debugging facilities are missing. Only tracing is supported ++ natively. ++ ++ ++ Scheme Reference ++ ---------------- ++ ++ If something seems to be missing, please refer to the code and ++ "init.scm", since some are library functions. Refer to the MiniSCHEME ++ readme as a last resort. ++ ++ Environments ++ (interaction-environment) ++ See R5RS. In TinySCHEME, immutable list of association lists. ++ ++ (current-environment) ++ The environment in effect at the time of the call. An example of its ++ use and its utility can be found in the sample code that implements ++ packages in "init.scm": ++ ++ (macro (package form) ++ `(apply (lambda () ++ ,@(cdr form) ++ (current-environment)))) ++ ++ The environment containing the (local) definitions inside the closure ++ is returned as an immutable value. ++ ++ (defined? <symbol>) (defined? <symbol> <environment>) ++ Checks whether the given symbol is defined in the current (or given) ++ environment. ++ ++ Symbols ++ (gensym) ++ Returns a new interned symbol each time. Will probably move to the ++ library when string->symbol is implemented. ++ ++ Directives ++ (gc) ++ Performs garbage collection immediatelly. ++ ++ (gcverbose) (gcverbose <bool>) ++ The argument (defaulting to #t) controls whether GC produces ++ visible outcome. ++ ++ (quit) (quit <num>) ++ Stops the interpreter and sets the 'retcode' internal field (defaults ++ to 0). When standalone, 'retcode' is returned as exit code to the OS. ++ ++ (tracing <num>) ++ 1, turns on tracing. 0 turns it off. (Only when USE_TRACING is 1). ++ ++ Mathematical functions ++ Since rationals and complexes are absent, the respective functions ++ are also missing. ++ Supported: exp, log, sin, cos, tan, asin, acos, atan, floor, ceiling, ++ trunc, round and also sqrt and expt when USE_MATH=1. ++ Number-theoretical quotient, remainder and modulo, gcd, lcm. ++ Library: exact?, inexact?, odd?, even?, zero?, positive?, negative?, ++ exact->inexact. inexact->exact is a core function. ++ ++ Type predicates ++ boolean?,eof-object?,symbol?,number?,string?,integer?,real?,list?,null?, ++ char?,port?,input-port?,output-port?,procedure?,pair?,environment?', ++ vector?. Also closure?, macro?. ++ ++ Types ++ Types supported: ++ ++ Numbers (integers and reals) ++ Symbols ++ Pairs ++ Strings ++ Characters ++ Ports ++ Eof object ++ Environments ++ Vectors ++ ++ Literals ++ String literals can contain escaped quotes \" as usual, but also ++ \n, \r, \t, \xDD (hex representations) and \DDD (octal representations). ++ Note also that it is possible to include literal newlines in string ++ literals, e.g. ++ ++ (define s "String with newline here ++ and here ++ that can function like a HERE-string") ++ ++ Character literals contain #\space and #\newline and are supplemented ++ with #\return and #\tab, with obvious meanings. Hex character ++ representations are allowed (e.g. #\x20 is #\space). ++ When USE_ASCII_NAMES is defined, various control characters can be ++ referred to by their ASCII name. ++ 0 #\nul 17 #\dc1 ++ 1 #\soh 18 #\dc2 ++ 2 #\stx 19 #\dc3 ++ 3 #\etx 20 #\dc4 ++ 4 #\eot 21 #\nak ++ 5 #\enq 22 #\syn ++ 6 #\ack 23 #\etv ++ 7 #\bel 24 #\can ++ 8 #\bs 25 #\em ++ 9 #\ht 26 #\sub ++ 10 #\lf 27 #\esc ++ 11 #\vt 28 #\fs ++ 12 #\ff 29 #\gs ++ 13 #\cr 30 #\rs ++ 14 #\so 31 #\us ++ 15 #\si ++ 16 #\dle 127 #\del ++ ++ Numeric literals support #x #o #b and #d. Flonums are currently read only ++ in decimal notation. Full grammar will be supported soon. ++ ++ Quote, quasiquote etc. ++ As usual. ++ ++ Immutable values ++ Immutable pairs cannot be modified by set-car! and set-cdr!. ++ Immutable strings cannot be modified via string-set! ++ ++ I/O ++ As per R5RS, plus String Ports (see below). ++ current-input-port, current-output-port, ++ close-input-port, close-output-port, input-port?, output-port?, ++ open-input-file, open-output-file. ++ read, write, display, newline, write-char, read-char, peek-char. ++ char-ready? returns #t only for string ports, because there is no ++ portable way in stdio to determine if a character is available. ++ Also open-input-output-file, set-input-port, set-output-port (not R5RS) ++ Library: call-with-input-file, call-with-output-file, ++ with-input-from-file, with-output-from-file and ++ with-input-output-from-to-files, close-port and input-output-port? ++ (not R5RS). ++ String Ports: open-input-string, open-output-string, get-output-string, ++ open-input-output-string. Strings can be used with I/O routines. ++ ++ Vectors ++ make-vector, vector, vector-length, vector-ref, vector-set!, list->vector, ++ vector-fill!, vector->list, vector-equal? (auxiliary function, not R5RS) ++ ++ Strings ++ string, make-string, list->string, string-length, string-ref, string-set!, ++ substring, string->list, string-fill!, string-append, string-copy. ++ string=?, string<?, string>?, string>?, string<=?, string>=?. ++ (No string-ci*? yet). string->number, number->string. Also atom->string, ++ string->atom (not R5RS). ++ ++ Symbols ++ symbol->string, string->symbol ++ ++ Characters ++ integer->char, char->integer. ++ char=?, char<?, char>?, char<=?, char>=?. ++ (No char-ci*?) ++ ++ Pairs & Lists ++ cons, car, cdr, list, length, map, for-each, foldr, list-tail, ++ list-ref, last-pair, reverse, append. ++ Also member, memq, memv, based on generic-member, assoc, assq, assv ++ based on generic-assoc. ++ ++ Streams ++ head, tail, cons-stream ++ ++ Control features ++ Apart from procedure?, also macro? and closure? ++ map, for-each, force, delay, call-with-current-continuation (or call/cc), ++ eval, apply. 'Forcing' a value that is not a promise produces the value. ++ There is no call-with-values, values, nor dynamic-wind. Dynamic-wind in ++ the presence of continuations would require support from the abstract ++ machine itself. ++ ++ Property lists ++ TinyScheme inherited from MiniScheme property lists for symbols. ++ put, get. ++ ++ Dynamically-loaded extensions ++ (load-extension <filename without extension>) ++ Loads a DLL declaring foreign procedures. On Unix/Linux, one can make use ++ of the ld.so.conf file or the LD_RUN_PATH system variable in order to place ++ the library in a directory other than the current one. Please refer to the ++ appropriate 'man' page. ++ ++ Esoteric procedures ++ (oblist) ++ Returns the oblist, an immutable list of all the symbols. ++ ++ (macro-expand <form>) ++ Returns the expanded form of the macro call denoted by the argument ++ ++ (define-with-return (<procname> <args>...) <body>) ++ Like plain 'define', but makes the continuation available as 'return' ++ inside the procedure. Handy for imperative programs. ++ ++ (new-segment <num>) ++ Allocates more memory segments. ++ ++ defined? ++ See "Environments" ++ ++ (get-closure-code <closure>) ++ Gets the code as scheme data. ++ ++ (make-closure <code> <environment>) ++ Makes a new closure in the given environment. ++ ++ Obsolete procedures ++ (print-width <object>) ++ ++ Programmer's Reference ++ ---------------------- ++ ++ The interpreter state is initialized with "scheme_init". ++ Custom memory allocation routines can be installed with an alternate ++ initialization function: "scheme_init_custom_alloc". ++ Files can be loaded with "scheme_load_file". Strings containing Scheme ++ code can be loaded with "scheme_load_string". It is a good idea to ++ "scheme_load" init.scm before anything else. ++ ++ External data for keeping external state (of use to foreign functions) ++ can be installed with "scheme_set_external_data". ++ Foreign functions are installed with "assign_foreign". Additional ++ definitions can be added to the interpreter state, with "scheme_define" ++ (this is the way HTTP header data and HTML form data are passed to the ++ Scheme script in the Altera SQL Server). If you wish to define the ++ foreign function in a specific environment (to enhance modularity), ++ use "assign_foreign_env". ++ ++ The procedure "scheme_apply0" has been added with persistent scripts in ++ mind. Persistent scripts are loaded once, and every time they are needed ++ to produce HTTP output, appropriate data are passed through global ++ definitions and function "main" is called to do the job. One could ++ add easily "scheme_apply1" etc. ++ ++ The interpreter state should be deinitialized with "scheme_deinit". ++ ++ DLLs containing foreign functions should define a function named ++ init_<base-name>. E.g. foo.dll should define init_foo, and bar.so ++ should define init_bar. This function should assign_foreign any foreign ++ function contained in the DLL. ++ ++ The first dynamically loaded extension available for TinyScheme is ++ a regular expression library. Although it's by no means an ++ established standard, this library is supposed to be installed in ++ a directory mirroring its name under the TinyScheme location. ++ ++ ++ Foreign Functions ++ ----------------- ++ ++ The user can add foreign functions in C. For example, a function ++ that squares its argument: ++ ++ pointer square(scheme *sc, pointer args) { ++ if(args!=sc->NIL) { ++ if(sc->isnumber(sc->pair_car(args))) { ++ double v=sc->rvalue(sc->pair_car(args)); ++ return sc->mk_real(sc,v*v); ++ } ++ } ++ return sc->NIL; ++ } ++ ++ Foreign functions are now defined as closures: ++ ++ sc->interface->scheme_define( ++ sc, ++ sc->global_env, ++ sc->interface->mk_symbol(sc,"square"), ++ sc->interface->mk_foreign_func(sc, square)); ++ ++ ++ Foreign functions can use the external data in the "scheme" struct ++ to implement any kind of external state. ++ ++ External data are set with the following function: ++ void scheme_set_external_data(scheme *sc, void *p); ++ ++ As of v.1.17, the canonical way for a foreign function in a DLL to ++ manipulate Scheme data is using the function pointers in sc->interface. ++ ++ Standalone ++ ---------- ++ ++ Usage: tinyscheme -? ++ or: tinyscheme [<file1> <file2> ...] ++ followed by ++ -1 <file> [<arg1> <arg2> ...] ++ -c <Scheme commands> [<arg1> <arg2> ...] ++ assuming that the executable is named tinyscheme. ++ ++ Use - in the place of a filename to denote stdin. ++ The -1 flag is meant for #! usage in shell scripts. If you specify ++ #! /somewhere/tinyscheme -1 ++ then tinyscheme will be called to process the file. For example, the ++ following script echoes the Scheme list of its arguments. ++ ++ #! /somewhere/tinyscheme -1 ++ (display *args*) ++ ++ The -c flag permits execution of arbitrary Scheme code. ++ ++ ++ Error Handling ++ -------------- ++ ++ Errors are recovered from without damage. The user can install his ++ own handler for system errors, by defining *error-hook*. Defining ++ to '() gives the default behavior, which is equivalent to "error". ++ USE_ERROR_HOOK must be defined. ++ ++ A simple exception handling mechanism can be found in "init.scm". ++ A new syntactic form is introduced: ++ ++ (catch <expr returned exceptionally> ++ <expr1> <expr2> ... <exprN>) ++ ++ "Catch" establishes a scope spanning multiple call-frames ++ until another "catch" is encountered. ++ ++ Exceptions are thrown with: ++ ++ (throw "message") ++ ++ If used outside a (catch ...), reverts to (error "message"). ++ ++ Example of use: ++ ++ (define (foo x) (write x) (newline) (/ x 0)) ++ ++ (catch (begin (display "Error!\n") 0) ++ (write "Before foo ... ") ++ (foo 5) ++ (write "After foo")) ++ ++ The exception mechanism can be used even by system errors, by ++ ++ (define *error-hook* throw) ++ ++ which makes use of the error hook described above. ++ ++ If necessary, the user can devise his own exception mechanism with ++ tagged exceptions etc. ++ ++ ++ Reader extensions ++ ----------------- ++ ++ When encountering an unknown character after '#', the user-specified ++ procedure *sharp-hook* (if any), is called to read the expression. ++ This can be used to extend the reader to handle user-defined constants ++ or whatever. It should be a procedure without arguments, reading from ++ the current input port (which will be the load-port). ++ ++ ++ Colon Qualifiers - Packages ++ --------------------------- ++ ++ When USE_COLON_HOOK=1: ++ The lexer now recognizes the construction <qualifier>::<symbol> and ++ transforms it in the following manner (T is the transformation function): ++ ++ T(<qualifier>::<symbol>) = (*colon-hook* 'T(<symbol>) <qualifier>) ++ ++ where <qualifier> is a symbol not containing any double-colons. ++ ++ As the definition is recursive, qualifiers can be nested. ++ The user can define his own *colon-hook*, to handle qualified names. ++ By default, "init.scm" defines *colon-hook* as EVAL. Consequently, ++ the qualifier must denote a Scheme environment, such as one returned ++ by (interaction-environment). "Init.scm" defines a new syntantic form, ++ PACKAGE, as a simple example. It is used like this: ++ ++ (define toto ++ (package ++ (define foo 1) ++ (define bar +))) ++ ++ foo ==> Error, "foo" undefined ++ (eval 'foo) ==> Error, "foo" undefined ++ (eval 'foo toto) ==> 1 ++ toto::foo ==> 1 ++ ((eval 'bar toto) 2 (eval 'foo toto)) ==> 3 ++ (toto::bar 2 toto::foo) ==> 3 ++ (eval (bar 2 foo) toto) ==> 3 ++ ++ If the user installs another package infrastructure, he must define ++ a new 'package' procedure or macro to retain compatibility with supplied ++ code. ++ ++ Note: Older versions used ':' as a qualifier. Unfortunately, the use ++ of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially ++ precludes its use as a real qualifier. ++ ++ ++ ++ ++ ++ ++ ++ +diff --git a/bootshell/MiniSCHEMETribute.txt b/bootshell/MiniSCHEMETribute.txt +new file mode 100644 +index 0000000..02ebd26 +--- /dev/null ++++ b/bootshell/MiniSCHEMETribute.txt +@@ -0,0 +1,88 @@ ++ TinyScheme would not exist if it wasn't for MiniScheme. I had just ++ written the HTTP server for Ovrimos SQL Server, and I was lamenting the ++ lack of a scripting language. Server-side Javascript would have been the ++ preferred solution, had there been a Javascript interpreter I could ++ lay my hands on. But there weren't. Perl would have been another solution, ++ but it was probably ten times bigger that the program it was supposed to ++ be embedded in. There would also be thorny licencing issues. ++ ++ So, the obvious thing to do was find a trully small interpreter. Forth ++ was a language I had once quasi-implemented, but the difficulty of ++ handling dynamic data and the weirdness of the language put me off. I then ++ looked around for a LISP interpreter, the next thing I knew was easy to ++ implement. Alas, the LeLisp I knew from my days in UPMC (Universite Pierre ++ et Marie Curie) had given way to Common Lisp, a megalith of a language! ++ Then my search lead me to Scheme, a language I knew was very orthogonal ++ and clean. When I found Mini-Scheme, a single C file of some 2400 loc, I ++ fell in love with it! What if it lacked floating-point numbers and ++ strings! The rest, as they say, is history. ++ ++ Below are the original credits. Don't email Akira KIDA, the address has ++ changed. ++ ++ ---------- 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 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: ++ <SDI00379@niftyserve.or.jp> ++ ++ ++ Features compared to MiniSCHEME ++ ------------------------------- ++ ++ All code is now reentrant. Interpreter state is held in a 'scheme' ++ struct, and many interpreters can coexist in the same program, possibly ++ in different threads. The user can specify user-defined memory allocation ++ primitives. (see "Programmer's Reference") ++ ++ The reader is more consistent. ++ ++ Strings, characters and flonums are supported. (see "Types") ++ ++ Files being loaded can be nested up to some depth. ++ ++ R5RS I/O is there, plus String Ports. (see "Scheme Reference","I/O") ++ ++ Vectors exist. ++ ++ As a standalone application, it supports command-line arguments. ++ (see "Standalone") ++ ++ Running out of memory is now handled. ++ ++ The user can add foreign functions in C. (see "Foreign Functions") ++ ++ The code has been changed slightly, core functions have been moved ++ to the library, behavior has been aligned with R5RS etc. ++ ++ Support has been added for user-defined error recovery. ++ (see "Error Handling") ++ ++ Support has been added for modular programming. ++ (see "Colon Qualifiers - Packages") ++ ++ To enable this, EVAL has changed internally, and can ++ now take two arguments, as per R5RS. Environments are supported. ++ (see "Colon Qualifiers - Packages") ++ ++ Promises are now evaluated once only. ++ ++ (macro (foo form) ...) is now equivalent to (macro foo (lambda(form) ...)) ++ ++ The reader can be extended using new #-expressions ++ (see "Reader extensions") +diff --git a/bootshell/hack.txt b/bootshell/hack.txt +new file mode 100644 +index 0000000..f3ee648 +--- /dev/null ++++ b/bootshell/hack.txt +@@ -0,0 +1,244 @@ ++ ++ How to hack TinyScheme ++ ---------------------- ++ ++ TinyScheme is easy to learn and modify. It is structured like a ++ meta-interpreter, only it is written in C. All data are Scheme ++ objects, which facilitates both understanding/modifying the ++ code and reifying the interpreter workings. ++ ++ In place of a dry description, we will pace through the addition ++ of a useful new datatype: garbage-collected memory blocks. ++ The interface will be: ++ ++ (make-block <n> [<fill>]) makes a new block of the specified size ++ optionally filling it with a specified byte ++ (block? <obj>) ++ (block-length <block>) ++ (block-ref <block> <index>) retrieves byte at location ++ (block-set! <block> <index> <byte>) modifies byte at location ++ ++ In the sequel, lines that begin with '>' denote lines to add to the ++ code. Lines that begin with '|' are just citations of existing code. ++ Lines that begin with X denote lines to be removed from the code. ++ ++ First of all, we need to assign a typeid to our new type. Typeids ++ in TinyScheme are small integers declared in the scheme_types enum ++ located near the top of the scheme.c file; it begins with T_STRING. ++ Add a new entry at the end, say T_MEMBLOCK. Remember to adjust the ++ value of T_LAST_SYTEM_TYPE when adding new entries. There can be at ++ most 31 types, but you don't have to worry about that limit yet. ++ ++| T_ENVIRONMENT=14, ++X T_LAST_SYSTEM_TYPE=14 ++> T_MEMBLOCK=15, ++> T_LAST_SYSTEM_TYPE=15 ++| }; ++ ++ ++ Then, some helper macros would be useful. Go to where is_string() ++ and the rest are defined and add: ++ ++> INTERFACE INLINE int is_memblock(pointer p) { return (type(p)==T_MEMBLOCK); } ++ ++ This actually is a function, because it is meant to be exported by ++ scheme.h. If no foreign function will ever manipulate a memory block, ++ you can instead define it as a macro: ++ ++> #define is_memblock(p) (type(p)==T_MEMBLOCK) ++ ++ Then we make space for the new type in the main data structure: ++ struct cell. As it happens, the _string part of the union _object ++ (that is used to hold character strings) has two fields that suit us: ++ ++| struct { ++| char *_svalue; ++| int _keynum; ++| } _string; ++ ++ We can use _svalue to hold the actual pointer and _keynum to hold its ++ length. If we couln't reuse existing fields, we could always add other ++ alternatives in union _object. ++ ++ We then proceed to write the function that actually makes a new block. ++ For conformance reasons, we name it mk_memblock ++ ++> static pointer mk_memblock(scheme *sc, int len, char fill) { ++> pointer x; ++> char *p=(char*)sc->malloc(len); ++> ++> if(p==0) { ++> return sc->NIL; ++> } ++> x = get_cell(sc, sc->NIL, sc->NIL); ++> ++> typeflag(x) = T_MEMBLOCK|T_ATOM; ++> strvalue(x)=p; ++> keynum(x)=len; ++> memset(p,fill,len); ++> return (x); ++> } ++ ++ The memory used by the MEMBLOCK will have to be freed when the cell ++ is reclaimed during garbage collection. There is a placeholder for ++ that staff, function finalize_cell(), currently handling strings only. ++ ++| static void finalize_cell(scheme *sc, pointer a) { ++| if(is_string(a)) { ++| sc->free(strvalue(a)); ++> } else if(is_memblock(a)) { ++> sc->free(strvalue(a)); ++| } else if(is_port(a)) { ++ ++ There are no MEMBLOCK literals, so we don't concern ourselves with ++ the READER part (yet!). We must cater to the PRINTER, though. We ++ add one case more in atom2str(). ++ ++| } else if (iscontinuation(l)) { ++| p = "#<CONTINUATION>"; ++> } else if (is_memblock(l)) { ++> p = "#<MEMORY BLOCK>"; ++| } else { ++ ++ Whenever a MEMBLOCK is displayed, it will look like that. ++ Now, we must add the interface functions: constructor, predicate, ++ accessor, modifier. We must in fact create new op-codes for the virtual ++ machine underlying TinyScheme. Since version 1.30, TinyScheme uses ++ macros and a single source text to keep the enums and the dispatch table ++ in sync. The op-codes are defined in the opdefines.h file with one line ++ for each op-code. The lines in the file have six columns between the ++ starting _OPDEF( and ending ): A, B, C, D, E, and OP. ++ Note that this file uses unusually long lines to accomodate all the ++ information; adjust your editor to handle this. ++ ++ The purpose of the columns is: ++ - Column A is the name of the subroutine that handles the op-code. ++ - Column B is the name of the op-code function. ++ - Columns C and D are the minimum and maximum number of arguments ++ that are accepted by the op-code. ++ - Column E is a set of flags that tells the interpreter the type of ++ each of the arguments expected by the op-code. ++ - Column OP is used in the scheme_opcodes enum located in the ++ scheme-private.h file. ++ ++ Op-codes are really just tags for a huge C switch, only this switch ++ is broken up in to a number of different opexe_X functions. The ++ correspondence is made in table "dispatch_table". There, we assign ++ the new op-codes to opexe_2, where the equivalent ones for vectors ++ are situated. We also assign a name for them, and specify the minimum ++ and maximum arity (number of expected arguments). INF_ARG as a maximum ++ arity means "unlimited". ++ ++ For reasons of consistency, we add the new op-codes right after those ++ for vectors: ++ ++| _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) ++> _OP_DEF(opexe_2, "make-block", 1, 2, TST_NATURAL TST_CHAR, OP_MKBLOCK ) ++> _OP_DEF(opexe_2, "block-length", 1, 1, T_MEMBLOCK, OP_BLOCKLEN ) ++> _OP_DEF(opexe_2, "block-ref", 2, 2, T_MEMBLOCK TST_NATURAL, OP_BLOCKREF ) ++> _OP_DEF(opexe_2, "block-set!", 1, 1, T_MEMBLOCK TST_NATURAL TST_CHAR, OP_BLOCKSET ) ++| _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT ) ++ ++ We add the predicate along with the other predicates in opexe_3: ++ ++| _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP ) ++> _OP_DEF(opexe_3, "block?", 1, 1, TST_ANY, OP_BLOCKP ) ++| _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ ) ++ ++ All that remains is to write the actual code to do the processing and ++ add it to the switch statement in opexe_2, after the OP_VECSET case. ++ ++> case OP_MKBLOCK: { /* make-block */ ++> int fill=0; ++> int len; ++> ++> if(!isnumber(car(sc->args))) { ++> Error_1(sc,"make-block: not a number:",car(sc->args)); ++> } ++> len=ivalue(car(sc->args)); ++> if(len<=0) { ++> Error_1(sc,"make-block: not positive:",car(sc->args)); ++> } ++> ++> if(cdr(sc->args)!=sc->NIL) { ++> if(!isnumber(cadr(sc->args)) || ivalue(cadr(sc->args))<0) { ++> Error_1(sc,"make-block: not a positive number:",cadr(sc->args)); ++> } ++> fill=charvalue(cadr(sc->args))%255; ++> } ++> s_return(sc,mk_memblock(sc,len,(char)fill)); ++> } ++> ++> case OP_BLOCKLEN: /* block-length */ ++> if(!ismemblock(car(sc->args))) { ++> Error_1(sc,"block-length: not a memory block:",car(sc->args)); ++> } ++> s_return(sc,mk_integer(sc,keynum(car(sc->args)))); ++> ++> case OP_BLOCKREF: { /* block-ref */ ++> char *str; ++> int index; ++> ++> if(!ismemblock(car(sc->args))) { ++> Error_1(sc,"block-ref: not a memory block:",car(sc->args)); ++> } ++> str=strvalue(car(sc->args)); ++> ++> if(cdr(sc->args)==sc->NIL) { ++> Error_0(sc,"block-ref: needs two arguments"); ++> } ++> if(!isnumber(cadr(sc->args))) { ++> Error_1(sc,"block-ref: not a number:",cadr(sc->args)); ++> } ++> index=ivalue(cadr(sc->args)); ++> ++> if(index<0 || index>=keynum(car(sc->args))) { ++> Error_1(sc,"block-ref: out of bounds:",cadr(sc->args)); ++> } ++> ++> s_return(sc,mk_integer(sc,str[index])); ++> } ++> ++> case OP_BLOCKSET: { /* block-set! */ ++> char *str; ++> int index; ++> int c; ++> ++> if(!ismemblock(car(sc->args))) { ++> Error_1(sc,"block-set!: not a memory block:",car(sc->args)); ++> } ++> if(isimmutable(car(sc->args))) { ++> Error_1(sc,"block-set!: unable to alter immutable memory block:",car(sc->args)); ++> } ++> str=strvalue(car(sc->args)); ++> ++> if(cdr(sc->args)==sc->NIL) { ++> Error_0(sc,"block-set!: needs three arguments"); ++> } ++> if(!isnumber(cadr(sc->args))) { ++> Error_1(sc,"block-set!: not a number:",cadr(sc->args)); ++> } ++> index=ivalue(cadr(sc->args)); ++> if(index<0 || index>=keynum(car(sc->args))) { ++> Error_1(sc,"block-set!: out of bounds:",cadr(sc->args)); ++> } ++> ++> if(cddr(sc->args)==sc->NIL) { ++> Error_0(sc,"block-set!: needs three arguments"); ++> } ++> if(!isinteger(caddr(sc->args))) { ++> Error_1(sc,"block-set!: not an integer:",caddr(sc->args)); ++> } ++> c=ivalue(caddr(sc->args))%255; ++> ++> str[index]=(char)c; ++> s_return(sc,car(sc->args)); ++> } ++ ++ Finally, do the same for the predicate in opexe_3. ++ ++| case OP_VECTORP: /* vector? */ ++| s_retbool(is_vector(car(sc->args))); ++> case OP_BLOCKP: /* block? */ ++> s_retbool(is_memblock(car(sc->args))); ++| case OP_EQ: /* eq? */ +diff --git a/bootshell/init.scm b/bootshell/init.scm +new file mode 100644 +index 0000000..223e421 +--- /dev/null ++++ b/bootshell/init.scm +@@ -0,0 +1,716 @@ ++; Initialization file for TinySCHEME 1.41 ++ ++; Per R5RS, up to four deep compositions should be defined ++(define (caar x) (car (car x))) ++(define (cadr x) (car (cdr x))) ++(define (cdar x) (cdr (car x))) ++(define (cddr x) (cdr (cdr x))) ++(define (caaar x) (car (car (car x)))) ++(define (caadr x) (car (car (cdr x)))) ++(define (cadar x) (car (cdr (car x)))) ++(define (caddr x) (car (cdr (cdr x)))) ++(define (cdaar x) (cdr (car (car x)))) ++(define (cdadr x) (cdr (car (cdr x)))) ++(define (cddar x) (cdr (cdr (car x)))) ++(define (cdddr x) (cdr (cdr (cdr x)))) ++(define (caaaar x) (car (car (car (car x))))) ++(define (caaadr x) (car (car (car (cdr x))))) ++(define (caadar x) (car (car (cdr (car x))))) ++(define (caaddr x) (car (car (cdr (cdr x))))) ++(define (cadaar x) (car (cdr (car (car x))))) ++(define (cadadr x) (car (cdr (car (cdr x))))) ++(define (caddar x) (car (cdr (cdr (car x))))) ++(define (cadddr x) (car (cdr (cdr (cdr x))))) ++(define (cdaaar x) (cdr (car (car (car x))))) ++(define (cdaadr x) (cdr (car (car (cdr x))))) ++(define (cdadar x) (cdr (car (cdr (car x))))) ++(define (cdaddr x) (cdr (car (cdr (cdr x))))) ++(define (cddaar x) (cdr (cdr (car (car x))))) ++(define (cddadr x) (cdr (cdr (car (cdr x))))) ++(define (cdddar x) (cdr (cdr (cdr (car x))))) ++(define (cddddr x) (cdr (cdr (cdr (cdr x))))) ++ ++;;;; Utility to ease macro creation ++(define (macro-expand form) ++ ((eval (get-closure-code (eval (car form)))) form)) ++ ++(define (macro-expand-all form) ++ (if (macro? form) ++ (macro-expand-all (macro-expand form)) ++ form)) ++ ++(define *compile-hook* macro-expand-all) ++ ++ ++(macro (unless form) ++ `(if (not ,(cadr form)) (begin ,@(cddr form)))) ++ ++(macro (when form) ++ `(if ,(cadr form) (begin ,@(cddr form)))) ++ ++; DEFINE-MACRO Contributed by Andy Gaynor ++(macro (define-macro dform) ++ (if (symbol? (cadr dform)) ++ `(macro ,@(cdr dform)) ++ (let ((form (gensym))) ++ `(macro (,(caadr dform) ,form) ++ (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form)))))) ++ ++; Utilities for math. Notice that inexact->exact is primitive, ++; but exact->inexact is not. ++(define exact? integer?) ++(define (inexact? x) (and (real? x) (not (integer? x)))) ++(define (even? n) (= (remainder n 2) 0)) ++(define (odd? n) (not (= (remainder n 2) 0))) ++(define (zero? n) (= n 0)) ++(define (positive? n) (> n 0)) ++(define (negative? n) (< n 0)) ++(define complex? number?) ++(define rational? real?) ++(define (abs n) (if (>= n 0) n (- n))) ++(define (exact->inexact n) (* n 1.0)) ++(define (<> n1 n2) (not (= n1 n2))) ++ ++; min and max must return inexact if any arg is inexact; use (+ n 0.0) ++(define (max . lst) ++ (foldr (lambda (a b) ++ (if (> a b) ++ (if (exact? b) a (+ a 0.0)) ++ (if (exact? a) b (+ b 0.0)))) ++ (car lst) (cdr lst))) ++(define (min . lst) ++ (foldr (lambda (a b) ++ (if (< a b) ++ (if (exact? b) a (+ a 0.0)) ++ (if (exact? a) b (+ b 0.0)))) ++ (car lst) (cdr lst))) ++ ++(define (succ x) (+ x 1)) ++(define (pred x) (- x 1)) ++(define gcd ++ (lambda a ++ (if (null? a) ++ 0 ++ (let ((aa (abs (car a))) ++ (bb (abs (cadr a)))) ++ (if (= bb 0) ++ aa ++ (gcd bb (remainder aa bb))))))) ++(define lcm ++ (lambda a ++ (if (null? a) ++ 1 ++ (let ((aa (abs (car a))) ++ (bb (abs (cadr a)))) ++ (if (or (= aa 0) (= bb 0)) ++ 0 ++ (abs (* (quotient aa (gcd aa bb)) bb))))))) ++ ++ ++(define (string . charlist) ++ (list->string charlist)) ++ ++(define (list->string charlist) ++ (let* ((len (length charlist)) ++ (newstr (make-string len)) ++ (fill-string! ++ (lambda (str i len charlist) ++ (if (= i len) ++ str ++ (begin (string-set! str i (car charlist)) ++ (fill-string! str (+ i 1) len (cdr charlist))))))) ++ (fill-string! newstr 0 len charlist))) ++ ++(define (string-fill! s e) ++ (let ((n (string-length s))) ++ (let loop ((i 0)) ++ (if (= i n) ++ s ++ (begin (string-set! s i e) (loop (succ i))))))) ++ ++(define (string->list s) ++ (let loop ((n (pred (string-length s))) (l '())) ++ (if (= n -1) ++ l ++ (loop (pred n) (cons (string-ref s n) l))))) ++ ++(define (string-copy str) ++ (string-append str)) ++ ++(define (string->anyatom str pred) ++ (let* ((a (string->atom str))) ++ (if (pred a) a ++ (error "string->xxx: not a xxx" a)))) ++ ++(define (string->number str . base) ++ (let ((n (string->atom str (if (null? base) 10 (car base))))) ++ (if (number? n) n #f))) ++ ++(define (anyatom->string n pred) ++ (if (pred n) ++ (atom->string n) ++ (error "xxx->string: not a xxx" n))) ++ ++(define (number->string n . base) ++ (atom->string n (if (null? base) 10 (car base)))) ++ ++ ++(define (char-cmp? cmp a b) ++ (cmp (char->integer a) (char->integer b))) ++(define (char-ci-cmp? cmp a b) ++ (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b)))) ++ ++(define (char=? a b) (char-cmp? = a b)) ++(define (char<? a b) (char-cmp? < a b)) ++(define (char>? a b) (char-cmp? > a b)) ++(define (char<=? a b) (char-cmp? <= a b)) ++(define (char>=? a b) (char-cmp? >= a b)) ++ ++(define (char-ci=? a b) (char-ci-cmp? = a b)) ++(define (char-ci<? a b) (char-ci-cmp? < a b)) ++(define (char-ci>? a b) (char-ci-cmp? > a b)) ++(define (char-ci<=? a b) (char-ci-cmp? <= a b)) ++(define (char-ci>=? a b) (char-ci-cmp? >= a b)) ++ ++; Note the trick of returning (cmp x y) ++(define (string-cmp? chcmp cmp a b) ++ (let ((na (string-length a)) (nb (string-length b))) ++ (let loop ((i 0)) ++ (cond ++ ((= i na) ++ (if (= i nb) (cmp 0 0) (cmp 0 1))) ++ ((= i nb) ++ (cmp 1 0)) ++ ((chcmp = (string-ref a i) (string-ref b i)) ++ (loop (succ i))) ++ (else ++ (chcmp cmp (string-ref a i) (string-ref b i))))))) ++ ++ ++(define (string=? a b) (string-cmp? char-cmp? = a b)) ++(define (string<? a b) (string-cmp? char-cmp? < a b)) ++(define (string>? a b) (string-cmp? char-cmp? > a b)) ++(define (string<=? a b) (string-cmp? char-cmp? <= a b)) ++(define (string>=? a b) (string-cmp? char-cmp? >= a b)) ++ ++(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b)) ++(define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b)) ++(define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b)) ++(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b)) ++(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b)) ++ ++(define (list . x) x) ++ ++(define (foldr f x lst) ++ (if (null? lst) ++ x ++ (foldr f (f x (car lst)) (cdr lst)))) ++ ++(define (unzip1-with-cdr . lists) ++ (unzip1-with-cdr-iterative lists '() '())) ++ ++(define (unzip1-with-cdr-iterative lists cars cdrs) ++ (if (null? lists) ++ (cons cars cdrs) ++ (let ((car1 (caar lists)) ++ (cdr1 (cdar lists))) ++ (unzip1-with-cdr-iterative ++ (cdr lists) ++ (append cars (list car1)) ++ (append cdrs (list cdr1)))))) ++ ++(define (map proc . lists) ++ (if (null? lists) ++ (apply proc) ++ (if (null? (car lists)) ++ '() ++ (let* ((unz (apply unzip1-with-cdr lists)) ++ (cars (car unz)) ++ (cdrs (cdr unz))) ++ (cons (apply proc cars) (apply map (cons proc cdrs))))))) ++ ++(define (for-each proc . lists) ++ (if (null? lists) ++ (apply proc) ++ (if (null? (car lists)) ++ #t ++ (let* ((unz (apply unzip1-with-cdr lists)) ++ (cars (car unz)) ++ (cdrs (cdr unz))) ++ (apply proc cars) (apply map (cons proc cdrs)))))) ++ ++(define (list-tail x k) ++ (if (zero? k) ++ x ++ (list-tail (cdr x) (- k 1)))) ++ ++(define (list-ref x k) ++ (car (list-tail x k))) ++ ++(define (last-pair x) ++ (if (pair? (cdr x)) ++ (last-pair (cdr x)) ++ x)) ++ ++(define (head stream) (car stream)) ++ ++(define (tail stream) (force (cdr stream))) ++ ++(define (vector-equal? x y) ++ (and (vector? x) (vector? y) (= (vector-length x) (vector-length y)) ++ (let ((n (vector-length x))) ++ (let loop ((i 0)) ++ (if (= i n) ++ #t ++ (and (equal? (vector-ref x i) (vector-ref y i)) ++ (loop (succ i)))))))) ++ ++(define (list->vector x) ++ (apply vector x)) ++ ++(define (vector-fill! v e) ++ (let ((n (vector-length v))) ++ (let loop ((i 0)) ++ (if (= i n) ++ v ++ (begin (vector-set! v i e) (loop (succ i))))))) ++ ++(define (vector->list v) ++ (let loop ((n (pred (vector-length v))) (l '())) ++ (if (= n -1) ++ l ++ (loop (pred n) (cons (vector-ref v n) l))))) ++ ++;; The following quasiquote macro is due to Eric S. Tiedemann. ++;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. ++;; ++;; Subsequently modified to handle vectors: D. Souflis ++ ++(macro ++ quasiquote ++ (lambda (l) ++ (define (mcons f l r) ++ (if (and (pair? r) ++ (eq? (car r) 'quote) ++ (eq? (car (cdr r)) (cdr f)) ++ (pair? l) ++ (eq? (car l) 'quote) ++ (eq? (car (cdr l)) (car f))) ++ (if (or (procedure? f) (number? f) (string? f)) ++ f ++ (list 'quote f)) ++ (if (eqv? l vector) ++ (apply l (eval r)) ++ (list 'cons l r) ++ ))) ++ (define (mappend f l r) ++ (if (or (null? (cdr f)) ++ (and (pair? r) ++ (eq? (car r) 'quote) ++ (eq? (car (cdr r)) '()))) ++ l ++ (list 'append l r))) ++ (define (foo level form) ++ (cond ((not (pair? form)) ++ (if (or (procedure? form) (number? form) (string? form)) ++ form ++ (list 'quote form)) ++ ) ++ ((eq? 'quasiquote (car form)) ++ (mcons form ''quasiquote (foo (+ level 1) (cdr form)))) ++ (#t (if (zero? level) ++ (cond ((eq? (car form) 'unquote) (car (cdr form))) ++ ((eq? (car form) 'unquote-splicing) ++ (error "Unquote-splicing wasn't in a list:" ++ form)) ++ ((and (pair? (car form)) ++ (eq? (car (car form)) 'unquote-splicing)) ++ (mappend form (car (cdr (car form))) ++ (foo level (cdr form)))) ++ (#t (mcons form (foo level (car form)) ++ (foo level (cdr form))))) ++ (cond ((eq? (car form) 'unquote) ++ (mcons form ''unquote (foo (- level 1) ++ (cdr form)))) ++ ((eq? (car form) 'unquote-splicing) ++ (mcons form ''unquote-splicing ++ (foo (- level 1) (cdr form)))) ++ (#t (mcons form (foo level (car form)) ++ (foo level (cdr form))))))))) ++ (foo 0 (car (cdr l))))) ++ ++;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom) ++(define (shared-tail x y) ++ (let ((len-x (length x)) ++ (len-y (length y))) ++ (define (shared-tail-helper x y) ++ (if ++ (eq? x y) ++ x ++ (shared-tail-helper (cdr x) (cdr y)))) ++ ++ (cond ++ ((> len-x len-y) ++ (shared-tail-helper ++ (list-tail x (- len-x len-y)) ++ y)) ++ ((< len-x len-y) ++ (shared-tail-helper ++ x ++ (list-tail y (- len-y len-x)))) ++ (#t (shared-tail-helper x y))))) ++ ++;;;;;Dynamic-wind by Tom Breton (Tehom) ++ ++;;Guarded because we must only eval this once, because doing so ++;;redefines call/cc in terms of old call/cc ++(unless (defined? 'dynamic-wind) ++ (let ++ ;;These functions are defined in the context of a private list of ++ ;;pairs of before/after procs. ++ ( (*active-windings* '()) ++ ;;We'll define some functions into the larger environment, so ++ ;;we need to know it. ++ (outer-env (current-environment))) ++ ++ ;;Poor-man's structure operations ++ (define before-func car) ++ (define after-func cdr) ++ (define make-winding cons) ++ ++ ;;Manage active windings ++ (define (activate-winding! new) ++ ((before-func new)) ++ (set! *active-windings* (cons new *active-windings*))) ++ (define (deactivate-top-winding!) ++ (let ((old-top (car *active-windings*))) ++ ;;Remove it from the list first so it's not active during its ++ ;;own exit. ++ (set! *active-windings* (cdr *active-windings*)) ++ ((after-func old-top)))) ++ ++ (define (set-active-windings! new-ws) ++ (unless (eq? new-ws *active-windings*) ++ (let ((shared (shared-tail new-ws *active-windings*))) ++ ++ ;;Define the looping functions. ++ ;;Exit the old list. Do deeper ones last. Don't do ++ ;;any shared ones. ++ (define (pop-many) ++ (unless (eq? *active-windings* shared) ++ (deactivate-top-winding!) ++ (pop-many))) ++ ;;Enter the new list. Do deeper ones first so that the ++ ;;deeper windings will already be active. Don't do any ++ ;;shared ones. ++ (define (push-many new-ws) ++ (unless (eq? new-ws shared) ++ (push-many (cdr new-ws)) ++ (activate-winding! (car new-ws)))) ++ ++ ;;Do it. ++ (pop-many) ++ (push-many new-ws)))) ++ ++ ;;The definitions themselves. ++ (eval ++ `(define call-with-current-continuation ++ ;;It internally uses the built-in call/cc, so capture it. ++ ,(let ((old-c/cc call-with-current-continuation)) ++ (lambda (func) ++ ;;Use old call/cc to get the continuation. ++ (old-c/cc ++ (lambda (continuation) ++ ;;Call func with not the continuation itself ++ ;;but a procedure that adjusts the active ++ ;;windings to what they were when we made ++ ;;this, and only then calls the ++ ;;continuation. ++ (func ++ (let ((current-ws *active-windings*)) ++ (lambda (x) ++ (set-active-windings! current-ws) ++ (continuation x))))))))) ++ outer-env) ++ ;;We can't just say "define (dynamic-wind before thunk after)" ++ ;;because the lambda it's defined to lives in this environment, ++ ;;not in the global environment. ++ (eval ++ `(define dynamic-wind ++ ,(lambda (before thunk after) ++ ;;Make a new winding ++ (activate-winding! (make-winding before after)) ++ (let ((result (thunk))) ++ ;;Get rid of the new winding. ++ (deactivate-top-winding!) ++ ;;The return value is that of thunk. ++ result))) ++ outer-env))) ++ ++(define call/cc call-with-current-continuation) ++ ++ ++;;;;; atom? and equal? written by a.k ++ ++;;;; atom? ++(define (atom? x) ++ (not (pair? x))) ++ ++;;;; equal? ++(define (equal? x y) ++ (cond ++ ((pair? x) ++ (and (pair? y) ++ (equal? (car x) (car y)) ++ (equal? (cdr x) (cdr y)))) ++ ((vector? x) ++ (and (vector? y) (vector-equal? x y))) ++ ((string? x) ++ (and (string? y) (string=? x y))) ++ (else (eqv? x y)))) ++ ++;;;; (do ((var init inc) ...) (endtest result ...) body ...) ++;; ++(macro do ++ (lambda (do-macro) ++ (apply (lambda (do vars endtest . body) ++ (let ((do-loop (gensym))) ++ `(letrec ((,do-loop ++ (lambda ,(map (lambda (x) ++ (if (pair? x) (car x) x)) ++ `,vars) ++ (if ,(car endtest) ++ (begin ,@(cdr endtest)) ++ (begin ++ ,@body ++ (,do-loop ++ ,@(map (lambda (x) ++ (cond ++ ((not (pair? x)) x) ++ ((< (length x) 3) (car x)) ++ (else (car (cdr (cdr x)))))) ++ `,vars))))))) ++ (,do-loop ++ ,@(map (lambda (x) ++ (if (and (pair? x) (cdr x)) ++ (car (cdr x)) ++ '())) ++ `,vars))))) ++ do-macro))) ++ ++;;;; generic-member ++(define (generic-member cmp obj lst) ++ (cond ++ ((null? lst) #f) ++ ((cmp obj (car lst)) lst) ++ (else (generic-member cmp obj (cdr lst))))) ++ ++(define (memq obj lst) ++ (generic-member eq? obj lst)) ++(define (memv obj lst) ++ (generic-member eqv? obj lst)) ++(define (member obj lst) ++ (generic-member equal? obj lst)) ++ ++;;;; generic-assoc ++(define (generic-assoc cmp obj alst) ++ (cond ++ ((null? alst) #f) ++ ((cmp obj (caar alst)) (car alst)) ++ (else (generic-assoc cmp obj (cdr alst))))) ++ ++(define (assq obj alst) ++ (generic-assoc eq? obj alst)) ++(define (assv obj alst) ++ (generic-assoc eqv? obj alst)) ++(define (assoc obj alst) ++ (generic-assoc equal? obj alst)) ++ ++(define (acons x y z) (cons (cons x y) z)) ++ ++;;;; Handy for imperative programs ++;;;; Used as: (define-with-return (foo x y) .... (return z) ...) ++(macro (define-with-return form) ++ `(define ,(cadr form) ++ (call/cc (lambda (return) ,@(cddr form))))) ++ ++;;;; Simple exception handling ++; ++; Exceptions are caught as follows: ++; ++; (catch (do-something to-recover and-return meaningful-value) ++; (if-something goes-wrong) ++; (with-these calls)) ++; ++; "Catch" establishes a scope spanning multiple call-frames ++; until another "catch" is encountered. ++; ++; Exceptions are thrown with: ++; ++; (throw "message") ++; ++; If used outside a (catch ...), reverts to (error "message) ++ ++(define *handlers* (list)) ++ ++(define (push-handler proc) ++ (set! *handlers* (cons proc *handlers*))) ++ ++(define (pop-handler) ++ (let ((h (car *handlers*))) ++ (set! *handlers* (cdr *handlers*)) ++ h)) ++ ++(define (more-handlers?) ++ (pair? *handlers*)) ++ ++(define (throw . x) ++ (if (more-handlers?) ++ (apply (pop-handler)) ++ (apply error x))) ++ ++(macro (catch form) ++ (let ((label (gensym))) ++ `(call/cc (lambda (exit) ++ (push-handler (lambda () (exit ,(cadr form)))) ++ (let ((,label (begin ,@(cddr form)))) ++ (pop-handler) ++ ,label))))) ++ ++(define *error-hook* throw) ++ ++ ++;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL ++ ++(macro (make-environment form) ++ `(apply (lambda () ++ ,@(cdr form) ++ (current-environment)))) ++ ++(define-macro (eval-polymorphic x . envl) ++ (display envl) ++ (let* ((env (if (null? envl) (current-environment) (eval (car envl)))) ++ (xval (eval x env))) ++ (if (closure? xval) ++ (make-closure (get-closure-code xval) env) ++ xval))) ++ ++; Redefine this if you install another package infrastructure ++; Also redefine 'package' ++(define *colon-hook* eval) ++ ++;;;;; I/O ++ ++(define (input-output-port? p) ++ (and (input-port? p) (output-port? p))) ++ ++(define (close-port p) ++ (cond ++ ((input-output-port? p) (close-input-port (close-output-port p))) ++ ((input-port? p) (close-input-port p)) ++ ((output-port? p) (close-output-port p)) ++ (else (throw "Not a port" p)))) ++ ++(define (call-with-input-file s p) ++ (let ((inport (open-input-file s))) ++ (if (eq? inport #f) ++ #f ++ (let ((res (p inport))) ++ (close-input-port inport) ++ res)))) ++ ++(define (call-with-output-file s p) ++ (let ((outport (open-output-file s))) ++ (if (eq? outport #f) ++ #f ++ (let ((res (p outport))) ++ (close-output-port outport) ++ res)))) ++ ++(define (with-input-from-file s p) ++ (let ((inport (open-input-file s))) ++ (if (eq? inport #f) ++ #f ++ (let ((prev-inport (current-input-port))) ++ (set-input-port inport) ++ (let ((res (p))) ++ (close-input-port inport) ++ (set-input-port prev-inport) ++ res))))) ++ ++(define (with-output-to-file s p) ++ (let ((outport (open-output-file s))) ++ (if (eq? outport #f) ++ #f ++ (let ((prev-outport (current-output-port))) ++ (set-output-port outport) ++ (let ((res (p))) ++ (close-output-port outport) ++ (set-output-port prev-outport) ++ res))))) ++ ++(define (with-input-output-from-to-files si so p) ++ (let ((inport (open-input-file si)) ++ (outport (open-input-file so))) ++ (if (not (and inport outport)) ++ (begin ++ (close-input-port inport) ++ (close-output-port outport) ++ #f) ++ (let ((prev-inport (current-input-port)) ++ (prev-outport (current-output-port))) ++ (set-input-port inport) ++ (set-output-port outport) ++ (let ((res (p))) ++ (close-input-port inport) ++ (close-output-port outport) ++ (set-input-port prev-inport) ++ (set-output-port prev-outport) ++ res))))) ++ ++; Random number generator (maximum cycle) ++(define *seed* 1) ++(define (random-next) ++ (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a))) ++ (set! *seed* ++ (- (* a (- *seed* ++ (* (quotient *seed* q) q))) ++ (* (quotient *seed* q) r))) ++ (if (< *seed* 0) (set! *seed* (+ *seed* m))) ++ *seed*)) ++;; SRFI-0 ++;; COND-EXPAND ++;; Implemented as a macro ++(define *features* '(srfi-0)) ++ ++(define-macro (cond-expand . cond-action-list) ++ (cond-expand-runtime cond-action-list)) ++ ++(define (cond-expand-runtime cond-action-list) ++ (if (null? cond-action-list) ++ #t ++ (if (cond-eval (caar cond-action-list)) ++ `(begin ,@(cdar cond-action-list)) ++ (cond-expand-runtime (cdr cond-action-list))))) ++ ++(define (cond-eval-and cond-list) ++ (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list)) ++ ++(define (cond-eval-or cond-list) ++ (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list)) ++ ++(define (cond-eval condition) ++ (cond ++ ((symbol? condition) ++ (if (member condition *features*) #t #f)) ++ ((eq? condition #t) #t) ++ ((eq? condition #f) #f) ++ (else (case (car condition) ++ ((and) (cond-eval-and (cdr condition))) ++ ((or) (cond-eval-or (cdr condition))) ++ ((not) (if (not (null? (cddr condition))) ++ (error "cond-expand : 'not' takes 1 argument") ++ (not (cond-eval (cadr condition))))) ++ (else (error "cond-expand : unknown operator" (car condition))))))) ++ ++(gc-verbose #f) +diff --git a/bootshell/opdefines.h b/bootshell/opdefines.h +new file mode 100644 +index 0000000..ceb4d0e +--- /dev/null ++++ b/bootshell/opdefines.h +@@ -0,0 +1,195 @@ ++ _OP_DEF(opexe_0, "load", 1, 1, TST_STRING, OP_LOAD ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T0LVL ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T1LVL ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_READ_INTERNAL ) ++ _OP_DEF(opexe_0, "gensym", 0, 0, 0, OP_GENSYM ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_VALUEPRINT ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_EVAL ) ++#if USE_TRACING ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_EVAL ) ++#endif ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E0ARGS ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E1ARGS ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY ) ++#if USE_TRACING ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_APPLY ) ++ _OP_DEF(opexe_0, "tracing", 1, 1, TST_NATURAL, OP_TRACING ) ++#endif ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DOMACRO ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA1 ) ++ _OP_DEF(opexe_0, "make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_QUOTE ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF0 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF1 ) ++ _OP_DEF(opexe_0, "defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_BEGIN ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF0 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF1 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET0 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET1 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0AST ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1AST ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2AST ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET0REC ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET1REC ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET2REC ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND0 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND1 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_DELAY ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND0 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND1 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR0 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR1 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C0STREAM ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C1STREAM ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO0 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO1 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE0 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE1 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE2 ) ++ _OP_DEF(opexe_1, "eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) ++ _OP_DEF(opexe_1, "apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) ++ _OP_DEF(opexe_1, "call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) ++#if USE_MATH ++ _OP_DEF(opexe_2, "inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) ++ _OP_DEF(opexe_2, "exp", 1, 1, TST_NUMBER, OP_EXP ) ++ _OP_DEF(opexe_2, "log", 1, 1, TST_NUMBER, OP_LOG ) ++ _OP_DEF(opexe_2, "sin", 1, 1, TST_NUMBER, OP_SIN ) ++ _OP_DEF(opexe_2, "cos", 1, 1, TST_NUMBER, OP_COS ) ++ _OP_DEF(opexe_2, "tan", 1, 1, TST_NUMBER, OP_TAN ) ++ _OP_DEF(opexe_2, "asin", 1, 1, TST_NUMBER, OP_ASIN ) ++ _OP_DEF(opexe_2, "acos", 1, 1, TST_NUMBER, OP_ACOS ) ++ _OP_DEF(opexe_2, "atan", 1, 2, TST_NUMBER, OP_ATAN ) ++ _OP_DEF(opexe_2, "sqrt", 1, 1, TST_NUMBER, OP_SQRT ) ++ _OP_DEF(opexe_2, "expt", 2, 2, TST_NUMBER, OP_EXPT ) ++ _OP_DEF(opexe_2, "floor", 1, 1, TST_NUMBER, OP_FLOOR ) ++ _OP_DEF(opexe_2, "ceiling", 1, 1, TST_NUMBER, OP_CEILING ) ++ _OP_DEF(opexe_2, "truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) ++ _OP_DEF(opexe_2, "round", 1, 1, TST_NUMBER, OP_ROUND ) ++#endif ++ _OP_DEF(opexe_2, "+", 0, INF_ARG, TST_NUMBER, OP_ADD ) ++ _OP_DEF(opexe_2, "-", 1, INF_ARG, TST_NUMBER, OP_SUB ) ++ _OP_DEF(opexe_2, "*", 0, INF_ARG, TST_NUMBER, OP_MUL ) ++ _OP_DEF(opexe_2, "/", 1, INF_ARG, TST_NUMBER, OP_DIV ) ++ _OP_DEF(opexe_2, "quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) ++ _OP_DEF(opexe_2, "remainder", 2, 2, TST_INTEGER, OP_REM ) ++ _OP_DEF(opexe_2, "modulo", 2, 2, TST_INTEGER, OP_MOD ) ++ _OP_DEF(opexe_2, "car", 1, 1, TST_PAIR, OP_CAR ) ++ _OP_DEF(opexe_2, "cdr", 1, 1, TST_PAIR, OP_CDR ) ++ _OP_DEF(opexe_2, "cons", 2, 2, TST_NONE, OP_CONS ) ++ _OP_DEF(opexe_2, "set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) ++ _OP_DEF(opexe_2, "set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) ++ _OP_DEF(opexe_2, "char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) ++ _OP_DEF(opexe_2, "integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) ++ _OP_DEF(opexe_2, "char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) ++ _OP_DEF(opexe_2, "char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) ++ _OP_DEF(opexe_2, "symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) ++ _OP_DEF(opexe_2, "atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) ++ _OP_DEF(opexe_2, "string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) ++ _OP_DEF(opexe_2, "string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) ++ _OP_DEF(opexe_2, "make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) ++ _OP_DEF(opexe_2, "string-length", 1, 1, TST_STRING, OP_STRLEN ) ++ _OP_DEF(opexe_2, "string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) ++ _OP_DEF(opexe_2, "string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) ++ _OP_DEF(opexe_2, "string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) ++ _OP_DEF(opexe_2, "substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) ++ _OP_DEF(opexe_2, "vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) ++ _OP_DEF(opexe_2, "make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) ++ _OP_DEF(opexe_2, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) ++ _OP_DEF(opexe_2, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) ++ _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) ++ _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT ) ++ _OP_DEF(opexe_3, "boolean?", 1, 1, TST_NONE, OP_BOOLP ) ++ _OP_DEF(opexe_3, "eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) ++ _OP_DEF(opexe_3, "null?", 1, 1, TST_NONE, OP_NULLP ) ++ _OP_DEF(opexe_3, "=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) ++ _OP_DEF(opexe_3, "<", 2, INF_ARG, TST_NUMBER, OP_LESS ) ++ _OP_DEF(opexe_3, ">", 2, INF_ARG, TST_NUMBER, OP_GRE ) ++ _OP_DEF(opexe_3, "<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) ++ _OP_DEF(opexe_3, ">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) ++ _OP_DEF(opexe_3, "symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) ++ _OP_DEF(opexe_3, "number?", 1, 1, TST_ANY, OP_NUMBERP ) ++ _OP_DEF(opexe_3, "string?", 1, 1, TST_ANY, OP_STRINGP ) ++ _OP_DEF(opexe_3, "integer?", 1, 1, TST_ANY, OP_INTEGERP ) ++ _OP_DEF(opexe_3, "real?", 1, 1, TST_ANY, OP_REALP ) ++ _OP_DEF(opexe_3, "char?", 1, 1, TST_ANY, OP_CHARP ) ++#if USE_CHAR_CLASSIFIERS ++ _OP_DEF(opexe_3, "char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) ++ _OP_DEF(opexe_3, "char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) ++ _OP_DEF(opexe_3, "char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) ++ _OP_DEF(opexe_3, "char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) ++ _OP_DEF(opexe_3, "char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) ++#endif ++ _OP_DEF(opexe_3, "port?", 1, 1, TST_ANY, OP_PORTP ) ++ _OP_DEF(opexe_3, "input-port?", 1, 1, TST_ANY, OP_INPORTP ) ++ _OP_DEF(opexe_3, "output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) ++ _OP_DEF(opexe_3, "procedure?", 1, 1, TST_ANY, OP_PROCP ) ++ _OP_DEF(opexe_3, "pair?", 1, 1, TST_ANY, OP_PAIRP ) ++ _OP_DEF(opexe_3, "list?", 1, 1, TST_ANY, OP_LISTP ) ++ _OP_DEF(opexe_3, "environment?", 1, 1, TST_ANY, OP_ENVP ) ++ _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP ) ++ _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ ) ++ _OP_DEF(opexe_3, "eqv?", 2, 2, TST_ANY, OP_EQV ) ++ _OP_DEF(opexe_4, "force", 1, 1, TST_ANY, OP_FORCE ) ++ _OP_DEF(opexe_4, 0, 0, 0, 0, OP_SAVE_FORCED ) ++ _OP_DEF(opexe_4, "write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) ++ _OP_DEF(opexe_4, "write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) ++ _OP_DEF(opexe_4, "display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) ++ _OP_DEF(opexe_4, "newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) ++ _OP_DEF(opexe_4, "error", 1, INF_ARG, TST_NONE, OP_ERR0 ) ++ _OP_DEF(opexe_4, 0, 0, 0, 0, OP_ERR1 ) ++ _OP_DEF(opexe_4, "reverse", 1, 1, TST_LIST, OP_REVERSE ) ++ _OP_DEF(opexe_4, "list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) ++ _OP_DEF(opexe_4, "append", 0, INF_ARG, TST_NONE, OP_APPEND ) ++#if USE_PLIST ++ _OP_DEF(opexe_4, "put", 3, 3, TST_NONE, OP_PUT ) ++ _OP_DEF(opexe_4, "get", 2, 2, TST_NONE, OP_GET ) ++#endif ++ _OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT ) ++ _OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC ) ++ _OP_DEF(opexe_4, "gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) ++ _OP_DEF(opexe_4, "new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) ++ _OP_DEF(opexe_4, "oblist", 0, 0, 0, OP_OBLIST ) ++ _OP_DEF(opexe_4, "current-input-port", 0, 0, 0, OP_CURR_INPORT ) ++ _OP_DEF(opexe_4, "current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) ++ _OP_DEF(opexe_4, "open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) ++ _OP_DEF(opexe_4, "open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) ++ _OP_DEF(opexe_4, "open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) ++#if USE_STRING_PORTS ++ _OP_DEF(opexe_4, "open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) ++ _OP_DEF(opexe_4, "open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) ++ _OP_DEF(opexe_4, "open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) ++ _OP_DEF(opexe_4, "get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) ++#endif ++ _OP_DEF(opexe_4, "close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) ++ _OP_DEF(opexe_4, "close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) ++ _OP_DEF(opexe_4, "interaction-environment", 0, 0, 0, OP_INT_ENV ) ++ _OP_DEF(opexe_4, "current-environment", 0, 0, 0, OP_CURR_ENV ) ++ _OP_DEF(opexe_5, "read", 0, 1, TST_INPORT, OP_READ ) ++ _OP_DEF(opexe_5, "read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) ++ _OP_DEF(opexe_5, "peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) ++ _OP_DEF(opexe_5, "char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) ++ _OP_DEF(opexe_5, "set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) ++ _OP_DEF(opexe_5, "set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDSEXPR ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDLIST ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDDOT ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQUOTE ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTE ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTEVEC ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUNQUOTE ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUQTSP ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDVEC ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P0LIST ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P1LIST ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_PVECFROM ) ++ _OP_DEF(opexe_6, "length", 1, 1, TST_LIST, OP_LIST_LENGTH ) ++ _OP_DEF(opexe_6, "assq", 2, 2, TST_NONE, OP_ASSQ ) ++ _OP_DEF(opexe_6, "get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) ++ _OP_DEF(opexe_6, "closure?", 1, 1, TST_NONE, OP_CLOSUREP ) ++ _OP_DEF(opexe_6, "macro?", 1, 1, TST_NONE, OP_MACROP ) ++#undef _OP_DEF +diff --git a/bootshell/scheme-private.h b/bootshell/scheme-private.h +new file mode 100644 +index 0000000..3395328 +--- /dev/null ++++ b/bootshell/scheme-private.h +@@ -0,0 +1,210 @@ ++/* scheme-private.h */ ++ ++#ifndef _SCHEME_PRIVATE_H ++#define _SCHEME_PRIVATE_H ++ ++#include "scheme.h" ++/*------------------ Ugly internals -----------------------------------*/ ++/*------------------ Of interest only to FFI users --------------------*/ ++ ++#ifdef __cplusplus ++extern "C" { ++#endif ++ ++enum scheme_port_kind { ++ port_free=0, ++ port_file=1, ++ port_string=2, ++ port_srfi6=4, ++ port_input=16, ++ port_output=32, ++ port_saw_EOF=64 ++}; ++ ++typedef struct port { ++ unsigned char kind; ++ union { ++ struct { ++ FILE *file; ++ int closeit; ++#if SHOW_ERROR_LINE ++ int curr_line; ++ char *filename; ++#endif ++ } stdio; ++ struct { ++ char *start; ++ char *past_the_end; ++ char *curr; ++ } string; ++ } rep; ++} port; ++ ++/* cell structure */ ++struct cell { ++ unsigned int _flag; ++ union { ++ struct { ++ char *_svalue; ++ int _length; ++ } _string; ++ num _number; ++ port *_port; ++ foreign_func _ff; ++ struct { ++ struct cell *_car; ++ struct cell *_cdr; ++ } _cons; ++ } _object; ++}; ++ ++struct scheme { ++/* arrays for segments */ ++func_alloc malloc; ++func_dealloc free; ++ ++/* return code */ ++int retcode; ++int tracing; ++ ++ ++#define CELL_SEGSIZE 5000 /* # of cells in one segment */ ++#define CELL_NSEGMENT 10 /* # of segments for cells */ ++char *alloc_seg[CELL_NSEGMENT]; ++pointer cell_seg[CELL_NSEGMENT]; ++int last_cell_seg; ++ ++/* We use 4 registers. */ ++pointer args; /* register for arguments of function */ ++pointer envir; /* stack register for current environment */ ++pointer code; /* register for current code */ ++pointer dump; /* stack register for next evaluation */ ++ ++int interactive_repl; /* are we in an interactive REPL? */ ++ ++struct cell _sink; ++pointer sink; /* when mem. alloc. fails */ ++struct cell _NIL; ++pointer NIL; /* special cell representing empty cell */ ++struct cell _HASHT; ++pointer T; /* special cell representing #t */ ++struct cell _HASHF; ++pointer F; /* special cell representing #f */ ++struct cell _EOF_OBJ; ++pointer EOF_OBJ; /* special cell representing end-of-file object */ ++pointer oblist; /* pointer to symbol table */ ++pointer global_env; /* pointer to global environment */ ++pointer c_nest; /* stack for nested calls from C */ ++ ++/* global pointers to special symbols */ ++pointer LAMBDA; /* pointer to syntax lambda */ ++pointer QUOTE; /* pointer to syntax quote */ ++ ++pointer QQUOTE; /* pointer to symbol quasiquote */ ++pointer UNQUOTE; /* pointer to symbol unquote */ ++pointer UNQUOTESP; /* pointer to symbol unquote-splicing */ ++pointer FEED_TO; /* => */ ++pointer COLON_HOOK; /* *colon-hook* */ ++pointer ERROR_HOOK; /* *error-hook* */ ++pointer SHARP_HOOK; /* *sharp-hook* */ ++pointer COMPILE_HOOK; /* *compile-hook* */ ++ ++pointer free_cell; /* pointer to top of free cells */ ++long fcells; /* # of free cells */ ++ ++pointer inport; ++pointer outport; ++pointer save_inport; ++pointer loadport; ++ ++#define MAXFIL 64 ++port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */ ++int nesting_stack[MAXFIL]; ++int file_i; ++int nesting; ++ ++char gc_verbose; /* if gc_verbose is not zero, print gc status */ ++char no_memory; /* Whether mem. alloc. has failed */ ++ ++#define LINESIZE 1024 ++char linebuff[LINESIZE]; ++#define STRBUFFSIZE 256 ++char strbuff[STRBUFFSIZE]; ++ ++FILE *tmpfp; ++int tok; ++int print_flag; ++pointer value; ++int op; ++ ++void *ext_data; /* For the benefit of foreign functions */ ++long gensym_cnt; ++ ++struct scheme_interface *vptr; ++void *dump_base; /* pointer to base of allocated dump stack */ ++int dump_size; /* number of frames allocated for dump stack */ ++}; ++ ++/* operator code */ ++enum scheme_opcodes { ++#define _OP_DEF(A,B,C,D,E,OP) OP, ++#include "opdefines.h" ++ OP_MAXDEFINED ++}; ++ ++ ++#define cons(sc,a,b) _cons(sc,a,b,0) ++#define immutable_cons(sc,a,b) _cons(sc,a,b,1) ++ ++int is_string(pointer p); ++char *string_value(pointer p); ++int is_number(pointer p); ++num nvalue(pointer p); ++long ivalue(pointer p); ++double rvalue(pointer p); ++int is_integer(pointer p); ++int is_real(pointer p); ++int is_character(pointer p); ++long charvalue(pointer p); ++int is_vector(pointer p); ++ ++int is_port(pointer p); ++ ++int is_pair(pointer p); ++pointer pair_car(pointer p); ++pointer pair_cdr(pointer p); ++pointer set_car(pointer p, pointer q); ++pointer set_cdr(pointer p, pointer q); ++ ++int is_symbol(pointer p); ++char *symname(pointer p); ++int hasprop(pointer p); ++ ++int is_syntax(pointer p); ++int is_proc(pointer p); ++int is_foreign(pointer p); ++char *syntaxname(pointer p); ++int is_closure(pointer p); ++#ifdef USE_MACRO ++int is_macro(pointer p); ++#endif ++pointer closure_code(pointer p); ++pointer closure_env(pointer p); ++ ++int is_continuation(pointer p); ++int is_promise(pointer p); ++int is_environment(pointer p); ++int is_immutable(pointer p); ++void setimmutable(pointer p); ++ ++#ifdef __cplusplus ++} ++#endif ++ ++#endif ++ ++/* ++Local variables: ++c-file-style: "k&r" ++End: ++*/ +diff --git a/bootshell/scheme.c b/bootshell/scheme.c +new file mode 100644 +index 0000000..99f9106 +--- /dev/null ++++ b/bootshell/scheme.c +@@ -0,0 +1,5051 @@ ++/* T I N Y S C H E M E 1 . 4 1 ++ * Dimitrios Souflis (dsouflis@acm.org) ++ * Based on MiniScheme (original credits follow) ++ * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) ++ * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp ++ * (MINISCM) This version has been modified by R.C. Secrist. ++ * (MINISCM) ++ * (MINISCM) Mini-Scheme is now maintained by Akira KIDA. ++ * (MINISCM) ++ * (MINISCM) This is a revised and modified version by Akira KIDA. ++ * (MINISCM) current version is 0.85k4 (15 May 1994) ++ * ++ */ ++ ++#define _SCHEME_SOURCE ++#include "scheme-private.h" ++#ifndef WIN32 ++# include <unistd.h> ++#endif ++#ifdef WIN32 ++#define snprintf _snprintf ++#endif ++#if USE_DL ++# include "dynload.h" ++#endif ++#if USE_MATH ++# include <math.h> ++#endif ++ ++#include <limits.h> ++#include <float.h> ++#include <ctype.h> ++ ++#if USE_STRCASECMP ++#include <strings.h> ++# ifndef __APPLE__ ++# define stricmp strcasecmp ++# endif ++#endif ++ ++/* Used for documentation purposes, to signal functions in 'interface' */ ++#define INTERFACE ++ ++#define TOK_EOF (-1) ++#define TOK_LPAREN 0 ++#define TOK_RPAREN 1 ++#define TOK_DOT 2 ++#define TOK_ATOM 3 ++#define TOK_QUOTE 4 ++#define TOK_COMMENT 5 ++#define TOK_DQUOTE 6 ++#define TOK_BQUOTE 7 ++#define TOK_COMMA 8 ++#define TOK_ATMARK 9 ++#define TOK_SHARP 10 ++#define TOK_SHARP_CONST 11 ++#define TOK_VEC 12 ++ ++#define BACKQUOTE '`' ++#define DELIMITERS "()\";\f\t\v\n\r " ++ ++/* ++ * Basic memory allocation units ++ */ ++ ++#define banner "TinyScheme 1.41" ++ ++#include <string.h> ++#include <stdlib.h> ++ ++#ifdef __APPLE__ ++static int stricmp(const char *s1, const char *s2) ++{ ++ unsigned char c1, c2; ++ do { ++ c1 = tolower(*s1); ++ c2 = tolower(*s2); ++ if (c1 < c2) ++ return -1; ++ else if (c1 > c2) ++ return 1; ++ s1++, s2++; ++ } while (c1 != 0); ++ return 0; ++} ++#endif /* __APPLE__ */ ++ ++#if USE_STRLWR ++static const char *strlwr(char *s) { ++ const char *p=s; ++ while(*s) { ++ *s=tolower(*s); ++ s++; ++ } ++ return p; ++} ++#endif ++ ++#ifndef prompt ++# define prompt "ts> " ++#endif ++ ++#ifndef InitFile ++# define InitFile "init.scm" ++#endif ++ ++#ifndef FIRST_CELLSEGS ++# define FIRST_CELLSEGS 3 ++#endif ++ ++enum scheme_types { ++ T_STRING=1, ++ T_NUMBER=2, ++ T_SYMBOL=3, ++ T_PROC=4, ++ T_PAIR=5, ++ T_CLOSURE=6, ++ T_CONTINUATION=7, ++ T_FOREIGN=8, ++ T_CHARACTER=9, ++ T_PORT=10, ++ T_VECTOR=11, ++ T_MACRO=12, ++ T_PROMISE=13, ++ T_ENVIRONMENT=14, ++ T_LAST_SYSTEM_TYPE=14 ++}; ++ ++/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ ++#define ADJ 32 ++#define TYPE_BITS 5 ++#define T_MASKTYPE 31 /* 0000000000011111 */ ++#define T_SYNTAX 4096 /* 0001000000000000 */ ++#define T_IMMUTABLE 8192 /* 0010000000000000 */ ++#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ ++#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ ++#define MARK 32768 /* 1000000000000000 */ ++#define UNMARK 32767 /* 0111111111111111 */ ++ ++ ++static num num_add(num a, num b); ++static num num_mul(num a, num b); ++static num num_div(num a, num b); ++static num num_intdiv(num a, num b); ++static num num_sub(num a, num b); ++static num num_rem(num a, num b); ++static num num_mod(num a, num b); ++static int num_eq(num a, num b); ++static int num_gt(num a, num b); ++static int num_ge(num a, num b); ++static int num_lt(num a, num b); ++static int num_le(num a, num b); ++ ++#if USE_MATH ++static double round_per_R5RS(double x); ++#endif ++static int is_zero_double(double x); ++static INLINE int num_is_integer(pointer p) { ++ return ((p)->_object._number.is_fixnum); ++} ++ ++static num num_zero; ++static num num_one; ++ ++/* macros for cell operations */ ++#define typeflag(p) ((p)->_flag) ++#define type(p) (typeflag(p)&T_MASKTYPE) ++ ++INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } ++#define strvalue(p) ((p)->_object._string._svalue) ++#define strlength(p) ((p)->_object._string._length) ++ ++INTERFACE static int is_list(scheme *sc, pointer p); ++INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } ++INTERFACE static void fill_vector(pointer vec, pointer obj); ++INTERFACE static pointer vector_elem(pointer vec, int ielem); ++INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); ++INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } ++INTERFACE INLINE int is_integer(pointer p) { ++ if (!is_number(p)) ++ return 0; ++ if (num_is_integer(p) || (double)ivalue(p) == rvalue(p)) ++ return 1; ++ return 0; ++} ++ ++INTERFACE INLINE int is_real(pointer p) { ++ return is_number(p) && (!(p)->_object._number.is_fixnum); ++} ++ ++INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); } ++INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); } ++INLINE num nvalue(pointer p) { return ((p)->_object._number); } ++INTERFACE long ivalue(pointer p) { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); } ++INTERFACE double rvalue(pointer p) { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); } ++#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue) ++#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue) ++#define set_num_integer(p) (p)->_object._number.is_fixnum=1; ++#define set_num_real(p) (p)->_object._number.is_fixnum=0; ++INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); } ++ ++INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); } ++INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; } ++INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; } ++ ++INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); } ++#define car(p) ((p)->_object._cons._car) ++#define cdr(p) ((p)->_object._cons._cdr) ++INTERFACE pointer pair_car(pointer p) { return car(p); } ++INTERFACE pointer pair_cdr(pointer p) { return cdr(p); } ++INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; } ++INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } ++ ++INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } ++INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } ++#if USE_PLIST ++SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); } ++#define symprop(p) cdr(p) ++#endif ++ ++INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } ++INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } ++INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } ++INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } ++#define procnum(p) ivalue(p) ++static const char *procname(pointer x); ++ ++INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } ++INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); } ++INTERFACE INLINE pointer closure_code(pointer p) { return car(p); } ++INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } ++ ++INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } ++#define cont_dump(p) cdr(p) ++ ++/* To do: promise should be forced ONCE only */ ++INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } ++ ++INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } ++#define setenvironment(p) typeflag(p) = T_ENVIRONMENT ++ ++#define is_atom(p) (typeflag(p)&T_ATOM) ++#define setatom(p) typeflag(p) |= T_ATOM ++#define clratom(p) typeflag(p) &= CLRATOM ++ ++#define is_mark(p) (typeflag(p)&MARK) ++#define setmark(p) typeflag(p) |= MARK ++#define clrmark(p) typeflag(p) &= UNMARK ++ ++INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); } ++/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/ ++INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } ++ ++#define caar(p) car(car(p)) ++#define cadr(p) car(cdr(p)) ++#define cdar(p) cdr(car(p)) ++#define cddr(p) cdr(cdr(p)) ++#define cadar(p) car(cdr(car(p))) ++#define caddr(p) car(cdr(cdr(p))) ++#define cdaar(p) cdr(car(car(p))) ++#define cadaar(p) car(cdr(car(car(p)))) ++#define cadddr(p) car(cdr(cdr(cdr(p)))) ++#define cddddr(p) cdr(cdr(cdr(cdr(p)))) ++ ++#if USE_CHAR_CLASSIFIERS ++static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } ++static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } ++static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); } ++static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); } ++static INLINE int Cislower(int c) { return isascii(c) && islower(c); } ++#endif ++ ++#if USE_ASCII_NAMES ++static const char *charnames[32]={ ++ "nul", ++ "soh", ++ "stx", ++ "etx", ++ "eot", ++ "enq", ++ "ack", ++ "bel", ++ "bs", ++ "ht", ++ "lf", ++ "vt", ++ "ff", ++ "cr", ++ "so", ++ "si", ++ "dle", ++ "dc1", ++ "dc2", ++ "dc3", ++ "dc4", ++ "nak", ++ "syn", ++ "etb", ++ "can", ++ "em", ++ "sub", ++ "esc", ++ "fs", ++ "gs", ++ "rs", ++ "us" ++}; ++ ++static int is_ascii_name(const char *name, int *pc) { ++ int i; ++ for(i=0; i<32; i++) { ++ if(stricmp(name,charnames[i])==0) { ++ *pc=i; ++ return 1; ++ } ++ } ++ if(stricmp(name,"del")==0) { ++ *pc=127; ++ return 1; ++ } ++ return 0; ++} ++ ++#endif ++ ++static int file_push(scheme *sc, const char *fname); ++static void file_pop(scheme *sc); ++static int file_interactive(scheme *sc); ++static INLINE int is_one_of(char *s, int c); ++static int alloc_cellseg(scheme *sc, int n); ++static long binary_decode(const char *s); ++static INLINE pointer get_cell(scheme *sc, pointer a, pointer b); ++static pointer _get_cell(scheme *sc, pointer a, pointer b); ++static pointer reserve_cells(scheme *sc, int n); ++static pointer get_consecutive_cells(scheme *sc, int n); ++static pointer find_consecutive_cells(scheme *sc, int n); ++static void finalize_cell(scheme *sc, pointer a); ++static int count_consecutive_cells(pointer x, int needed); ++static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); ++static pointer mk_number(scheme *sc, num n); ++static char *store_string(scheme *sc, int len, const char *str, char fill); ++static pointer mk_vector(scheme *sc, int len); ++static pointer mk_atom(scheme *sc, char *q); ++static pointer mk_sharp_const(scheme *sc, char *name); ++static pointer mk_port(scheme *sc, port *p); ++static pointer port_from_filename(scheme *sc, const char *fn, int prop); ++static pointer port_from_file(scheme *sc, FILE *, int prop); ++static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop); ++static port *port_rep_from_filename(scheme *sc, const char *fn, int prop); ++static port *port_rep_from_file(scheme *sc, FILE *, int prop); ++static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop); ++static void port_close(scheme *sc, pointer p, int flag); ++static void mark(pointer a); ++static void gc(scheme *sc, pointer a, pointer b); ++static int basic_inchar(port *pt); ++static int inchar(scheme *sc); ++static void backchar(scheme *sc, int c); ++static char *readstr_upto(scheme *sc, char *delim); ++static pointer readstrexp(scheme *sc); ++static INLINE int skipspace(scheme *sc); ++static int token(scheme *sc); ++static void printslashstring(scheme *sc, char *s, int len); ++static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen); ++static void printatom(scheme *sc, pointer l, int f); ++static pointer mk_proc(scheme *sc, enum scheme_opcodes op); ++static pointer mk_closure(scheme *sc, pointer c, pointer e); ++static pointer mk_continuation(scheme *sc, pointer d); ++static pointer reverse(scheme *sc, pointer a); ++static pointer reverse_in_place(scheme *sc, pointer term, pointer list); ++static pointer revappend(scheme *sc, pointer a, pointer b); ++static void dump_stack_mark(scheme *); ++static pointer opexe_0(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_1(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_2(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_3(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_4(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_5(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_6(scheme *sc, enum scheme_opcodes op); ++static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); ++static void assign_syntax(scheme *sc, char *name); ++static int syntaxnum(pointer p); ++static void assign_proc(scheme *sc, enum scheme_opcodes, char *name); ++ ++#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) ++#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) ++ ++static num num_add(num a, num b) { ++ num ret; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(ret.is_fixnum) { ++ ret.value.ivalue= a.value.ivalue+b.value.ivalue; ++ } else { ++ ret.value.rvalue=num_rvalue(a)+num_rvalue(b); ++ } ++ return ret; ++} ++ ++static num num_mul(num a, num b) { ++ num ret; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(ret.is_fixnum) { ++ ret.value.ivalue= a.value.ivalue*b.value.ivalue; ++ } else { ++ ret.value.rvalue=num_rvalue(a)*num_rvalue(b); ++ } ++ return ret; ++} ++ ++static num num_div(num a, num b) { ++ num ret; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0; ++ if(ret.is_fixnum) { ++ ret.value.ivalue= a.value.ivalue/b.value.ivalue; ++ } else { ++ ret.value.rvalue=num_rvalue(a)/num_rvalue(b); ++ } ++ return ret; ++} ++ ++static num num_intdiv(num a, num b) { ++ num ret; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(ret.is_fixnum) { ++ ret.value.ivalue= a.value.ivalue/b.value.ivalue; ++ } else { ++ ret.value.rvalue=num_rvalue(a)/num_rvalue(b); ++ } ++ return ret; ++} ++ ++static num num_sub(num a, num b) { ++ num ret; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(ret.is_fixnum) { ++ ret.value.ivalue= a.value.ivalue-b.value.ivalue; ++ } else { ++ ret.value.rvalue=num_rvalue(a)-num_rvalue(b); ++ } ++ return ret; ++} ++ ++static num num_rem(num a, num b) { ++ num ret; ++ long e1, e2, res; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ e1=num_ivalue(a); ++ e2=num_ivalue(b); ++ res=e1%e2; ++ /* remainder should have same sign as second operand */ ++ if (res > 0) { ++ if (e1 < 0) { ++ res -= labs(e2); ++ } ++ } else if (res < 0) { ++ if (e1 > 0) { ++ res += labs(e2); ++ } ++ } ++ ret.value.ivalue=res; ++ return ret; ++} ++ ++static num num_mod(num a, num b) { ++ num ret; ++ long e1, e2, res; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ e1=num_ivalue(a); ++ e2=num_ivalue(b); ++ res=e1%e2; ++ /* modulo should have same sign as second operand */ ++ if (res * e2 < 0) { ++ res += e2; ++ } ++ ret.value.ivalue=res; ++ return ret; ++} ++ ++static int num_eq(num a, num b) { ++ int ret; ++ int is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(is_fixnum) { ++ ret= a.value.ivalue==b.value.ivalue; ++ } else { ++ ret=num_rvalue(a)==num_rvalue(b); ++ } ++ return ret; ++} ++ ++ ++static int num_gt(num a, num b) { ++ int ret; ++ int is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(is_fixnum) { ++ ret= a.value.ivalue>b.value.ivalue; ++ } else { ++ ret=num_rvalue(a)>num_rvalue(b); ++ } ++ return ret; ++} ++ ++static int num_ge(num a, num b) { ++ return !num_lt(a,b); ++} ++ ++static int num_lt(num a, num b) { ++ int ret; ++ int is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(is_fixnum) { ++ ret= a.value.ivalue<b.value.ivalue; ++ } else { ++ ret=num_rvalue(a)<num_rvalue(b); ++ } ++ return ret; ++} ++ ++static int num_le(num a, num b) { ++ return !num_gt(a,b); ++} ++ ++#if USE_MATH ++/* Round to nearest. Round to even if midway */ ++static double round_per_R5RS(double x) { ++ double fl=floor(x); ++ double ce=ceil(x); ++ double dfl=x-fl; ++ double dce=ce-x; ++ if(dfl>dce) { ++ return ce; ++ } else if(dfl<dce) { ++ return fl; ++ } else { ++ if(fmod(fl,2.0)==0.0) { /* I imagine this holds */ ++ return fl; ++ } else { ++ return ce; ++ } ++ } ++} ++#endif ++ ++static int is_zero_double(double x) { ++ return x<DBL_MIN && x>-DBL_MIN; ++} ++ ++static long binary_decode(const char *s) { ++ long x=0; ++ ++ while(*s!=0 && (*s=='1' || *s=='0')) { ++ x<<=1; ++ x+=*s-'0'; ++ s++; ++ } ++ ++ return x; ++} ++ ++/* allocate new cell segment */ ++static int alloc_cellseg(scheme *sc, int n) { ++ pointer newp; ++ pointer last; ++ pointer p; ++ char *cp; ++ long i; ++ int k; ++ int adj=ADJ; ++ ++ if(adj<sizeof(struct cell)) { ++ adj=sizeof(struct cell); ++ } ++ ++ for (k = 0; k < n; k++) { ++ if (sc->last_cell_seg >= CELL_NSEGMENT - 1) ++ return k; ++ cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj); ++ if (cp == 0) ++ return k; ++ i = ++sc->last_cell_seg ; ++ sc->alloc_seg[i] = cp; ++ /* adjust in TYPE_BITS-bit boundary */ ++ if(((unsigned long)cp)%adj!=0) { ++ cp=(char*)(adj*((unsigned long)cp/adj+1)); ++ } ++ /* insert new segment in address order */ ++ newp=(pointer)cp; ++ sc->cell_seg[i] = newp; ++ while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) { ++ p = sc->cell_seg[i]; ++ sc->cell_seg[i] = sc->cell_seg[i - 1]; ++ sc->cell_seg[--i] = p; ++ } ++ sc->fcells += CELL_SEGSIZE; ++ last = newp + CELL_SEGSIZE - 1; ++ for (p = newp; p <= last; p++) { ++ typeflag(p) = 0; ++ cdr(p) = p + 1; ++ car(p) = sc->NIL; ++ } ++ /* insert new cells in address order on free list */ ++ if (sc->free_cell == sc->NIL || p < sc->free_cell) { ++ cdr(last) = sc->free_cell; ++ sc->free_cell = newp; ++ } else { ++ p = sc->free_cell; ++ while (cdr(p) != sc->NIL && newp > cdr(p)) ++ p = cdr(p); ++ cdr(last) = cdr(p); ++ cdr(p) = newp; ++ } ++ } ++ return n; ++} ++ ++static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) { ++ if (sc->free_cell != sc->NIL) { ++ pointer x = sc->free_cell; ++ sc->free_cell = cdr(x); ++ --sc->fcells; ++ return (x); ++ } ++ return _get_cell (sc, a, b); ++} ++ ++ ++/* get new cell. parameter a, b is marked by gc. */ ++static pointer _get_cell(scheme *sc, pointer a, pointer b) { ++ pointer x; ++ ++ if(sc->no_memory) { ++ return sc->sink; ++ } ++ ++ if (sc->free_cell == sc->NIL) { ++ const int min_to_be_recovered = sc->last_cell_seg*8; ++ gc(sc,a, b); ++ if (sc->fcells < min_to_be_recovered ++ || sc->free_cell == sc->NIL) { ++ /* if only a few recovered, get more to avoid fruitless gc's */ ++ if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) { ++ sc->no_memory=1; ++ return sc->sink; ++ } ++ } ++ } ++ x = sc->free_cell; ++ sc->free_cell = cdr(x); ++ --sc->fcells; ++ return (x); ++} ++ ++/* make sure that there is a given number of cells free */ ++static pointer reserve_cells(scheme *sc, int n) { ++ if(sc->no_memory) { ++ return sc->NIL; ++ } ++ ++ /* Are there enough cells available? */ ++ if (sc->fcells < n) { ++ /* If not, try gc'ing some */ ++ gc(sc, sc->NIL, sc->NIL); ++ if (sc->fcells < n) { ++ /* If there still aren't, try getting more heap */ ++ if (!alloc_cellseg(sc,1)) { ++ sc->no_memory=1; ++ return sc->NIL; ++ } ++ } ++ if (sc->fcells < n) { ++ /* If all fail, report failure */ ++ sc->no_memory=1; ++ return sc->NIL; ++ } ++ } ++ return (sc->T); ++} ++ ++static pointer get_consecutive_cells(scheme *sc, int n) { ++ pointer x; ++ ++ if(sc->no_memory) { return sc->sink; } ++ ++ /* Are there any cells available? */ ++ x=find_consecutive_cells(sc,n); ++ if (x != sc->NIL) { return x; } ++ ++ /* If not, try gc'ing some */ ++ gc(sc, sc->NIL, sc->NIL); ++ x=find_consecutive_cells(sc,n); ++ if (x != sc->NIL) { return x; } ++ ++ /* If there still aren't, try getting more heap */ ++ if (!alloc_cellseg(sc,1)) ++ { ++ sc->no_memory=1; ++ return sc->sink; ++ } ++ ++ x=find_consecutive_cells(sc,n); ++ if (x != sc->NIL) { return x; } ++ ++ /* If all fail, report failure */ ++ sc->no_memory=1; ++ return sc->sink; ++} ++ ++static int count_consecutive_cells(pointer x, int needed) { ++ int n=1; ++ while(cdr(x)==x+1) { ++ x=cdr(x); ++ n++; ++ if(n>needed) return n; ++ } ++ return n; ++} ++ ++static pointer find_consecutive_cells(scheme *sc, int n) { ++ pointer *pp; ++ int cnt; ++ ++ pp=&sc->free_cell; ++ while(*pp!=sc->NIL) { ++ cnt=count_consecutive_cells(*pp,n); ++ if(cnt>=n) { ++ pointer x=*pp; ++ *pp=cdr(*pp+n-1); ++ sc->fcells -= n; ++ return x; ++ } ++ pp=&cdr(*pp+cnt-1); ++ } ++ return sc->NIL; ++} ++ ++/* To retain recent allocs before interpreter knows about them - ++ Tehom */ ++ ++static void push_recent_alloc(scheme *sc, pointer recent, pointer extra) ++{ ++ pointer holder = get_cell_x(sc, recent, extra); ++ typeflag(holder) = T_PAIR | T_IMMUTABLE; ++ car(holder) = recent; ++ cdr(holder) = car(sc->sink); ++ car(sc->sink) = holder; ++} ++ ++ ++static pointer get_cell(scheme *sc, pointer a, pointer b) ++{ ++ pointer cell = get_cell_x(sc, a, b); ++ /* For right now, include "a" and "b" in "cell" so that gc doesn't ++ think they are garbage. */ ++ /* Tentatively record it as a pair so gc understands it. */ ++ typeflag(cell) = T_PAIR; ++ car(cell) = a; ++ cdr(cell) = b; ++ push_recent_alloc(sc, cell, sc->NIL); ++ return cell; ++} ++ ++static pointer get_vector_object(scheme *sc, int len, pointer init) ++{ ++ pointer cells = get_consecutive_cells(sc,len/2+len%2+1); ++ if(sc->no_memory) { return sc->sink; } ++ /* Record it as a vector so that gc understands it. */ ++ typeflag(cells) = (T_VECTOR | T_ATOM); ++ ivalue_unchecked(cells)=len; ++ set_num_integer(cells); ++ fill_vector(cells,init); ++ push_recent_alloc(sc, cells, sc->NIL); ++ return cells; ++} ++ ++static INLINE void ok_to_freely_gc(scheme *sc) ++{ ++ car(sc->sink) = sc->NIL; ++} ++ ++ ++#if defined TSGRIND ++static void check_cell_alloced(pointer p, int expect_alloced) ++{ ++ /* Can't use putstr(sc,str) because callers have no access to ++ sc. */ ++ if(typeflag(p) & !expect_alloced) ++ { ++ fprintf(stderr,"Cell is already allocated!\n"); ++ } ++ if(!(typeflag(p)) & expect_alloced) ++ { ++ fprintf(stderr,"Cell is not allocated!\n"); ++ } ++ ++} ++static void check_range_alloced(pointer p, int n, int expect_alloced) ++{ ++ int i; ++ for(i = 0;i<n;i++) ++ { (void)check_cell_alloced(p+i,expect_alloced); } ++} ++ ++#endif ++ ++/* Medium level cell allocation */ ++ ++/* get new cons cell */ ++pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { ++ pointer x = get_cell(sc,a, b); ++ ++ typeflag(x) = T_PAIR; ++ if(immutable) { ++ setimmutable(x); ++ } ++ car(x) = a; ++ cdr(x) = b; ++ return (x); ++} ++ ++/* ========== oblist implementation ========== */ ++ ++#ifndef USE_OBJECT_LIST ++ ++static int hash_fn(const char *key, int table_size); ++ ++static pointer oblist_initial_value(scheme *sc) ++{ ++ return mk_vector(sc, 461); /* probably should be bigger */ ++} ++ ++/* returns the new symbol */ ++static pointer oblist_add_by_name(scheme *sc, const char *name) ++{ ++ pointer x; ++ int location; ++ ++ x = immutable_cons(sc, mk_string(sc, name), sc->NIL); ++ typeflag(x) = T_SYMBOL; ++ setimmutable(car(x)); ++ ++ location = hash_fn(name, ivalue_unchecked(sc->oblist)); ++ set_vector_elem(sc->oblist, location, ++ immutable_cons(sc, x, vector_elem(sc->oblist, location))); ++ return x; ++} ++ ++static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) ++{ ++ int location; ++ pointer x; ++ char *s; ++ ++ location = hash_fn(name, ivalue_unchecked(sc->oblist)); ++ for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) { ++ s = symname(car(x)); ++ /* case-insensitive, per R5RS section 2. */ ++ if(stricmp(name, s) == 0) { ++ return car(x); ++ } ++ } ++ return sc->NIL; ++} ++ ++static pointer oblist_all_symbols(scheme *sc) ++{ ++ int i; ++ pointer x; ++ pointer ob_list = sc->NIL; ++ ++ for (i = 0; i < ivalue_unchecked(sc->oblist); i++) { ++ for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { ++ ob_list = cons(sc, x, ob_list); ++ } ++ } ++ return ob_list; ++} ++ ++#else ++ ++static pointer oblist_initial_value(scheme *sc) ++{ ++ return sc->NIL; ++} ++ ++static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) ++{ ++ pointer x; ++ char *s; ++ ++ for (x = sc->oblist; x != sc->NIL; x = cdr(x)) { ++ s = symname(car(x)); ++ /* case-insensitive, per R5RS section 2. */ ++ if(stricmp(name, s) == 0) { ++ return car(x); ++ } ++ } ++ return sc->NIL; ++} ++ ++/* returns the new symbol */ ++static pointer oblist_add_by_name(scheme *sc, const char *name) ++{ ++ pointer x; ++ ++ x = immutable_cons(sc, mk_string(sc, name), sc->NIL); ++ typeflag(x) = T_SYMBOL; ++ setimmutable(car(x)); ++ sc->oblist = immutable_cons(sc, x, sc->oblist); ++ return x; ++} ++static pointer oblist_all_symbols(scheme *sc) ++{ ++ return sc->oblist; ++} ++ ++#endif ++ ++static pointer mk_port(scheme *sc, port *p) { ++ pointer x = get_cell(sc, sc->NIL, sc->NIL); ++ ++ typeflag(x) = T_PORT|T_ATOM; ++ x->_object._port=p; ++ return (x); ++} ++ ++pointer mk_foreign_func(scheme *sc, foreign_func f) { ++ pointer x = get_cell(sc, sc->NIL, sc->NIL); ++ ++ typeflag(x) = (T_FOREIGN | T_ATOM); ++ x->_object._ff=f; ++ return (x); ++} ++ ++INTERFACE pointer mk_character(scheme *sc, int c) { ++ pointer x = get_cell(sc,sc->NIL, sc->NIL); ++ ++ typeflag(x) = (T_CHARACTER | T_ATOM); ++ ivalue_unchecked(x)= c; ++ set_num_integer(x); ++ return (x); ++} ++ ++/* get number atom (integer) */ ++INTERFACE pointer mk_integer(scheme *sc, long num) { ++ pointer x = get_cell(sc,sc->NIL, sc->NIL); ++ ++ typeflag(x) = (T_NUMBER | T_ATOM); ++ ivalue_unchecked(x)= num; ++ set_num_integer(x); ++ return (x); ++} ++ ++INTERFACE pointer mk_real(scheme *sc, double n) { ++ pointer x = get_cell(sc,sc->NIL, sc->NIL); ++ ++ typeflag(x) = (T_NUMBER | T_ATOM); ++ rvalue_unchecked(x)= n; ++ set_num_real(x); ++ return (x); ++} ++ ++static pointer mk_number(scheme *sc, num n) { ++ if(n.is_fixnum) { ++ return mk_integer(sc,n.value.ivalue); ++ } else { ++ return mk_real(sc,n.value.rvalue); ++ } ++} ++ ++/* allocate name to string area */ ++static char *store_string(scheme *sc, int len_str, const char *str, char fill) { ++ char *q; ++ ++ q=(char*)sc->malloc(len_str+1); ++ if(q==0) { ++ sc->no_memory=1; ++ return sc->strbuff; ++ } ++ if(str!=0) { ++ snprintf(q, len_str+1, "%s", str); ++ } else { ++ memset(q, fill, len_str); ++ q[len_str]=0; ++ } ++ return (q); ++} ++ ++/* get new string */ ++INTERFACE pointer mk_string(scheme *sc, const char *str) { ++ return mk_counted_string(sc,str,strlen(str)); ++} ++ ++INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { ++ pointer x = get_cell(sc, sc->NIL, sc->NIL); ++ typeflag(x) = (T_STRING | T_ATOM); ++ strvalue(x) = store_string(sc,len,str,0); ++ strlength(x) = len; ++ return (x); ++} ++ ++INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) { ++ pointer x = get_cell(sc, sc->NIL, sc->NIL); ++ typeflag(x) = (T_STRING | T_ATOM); ++ strvalue(x) = store_string(sc,len,0,fill); ++ strlength(x) = len; ++ return (x); ++} ++ ++INTERFACE static pointer mk_vector(scheme *sc, int len) ++{ return get_vector_object(sc,len,sc->NIL); } ++ ++INTERFACE static void fill_vector(pointer vec, pointer obj) { ++ int i; ++ int num=ivalue(vec)/2+ivalue(vec)%2; ++ for(i=0; i<num; i++) { ++ typeflag(vec+1+i) = T_PAIR; ++ setimmutable(vec+1+i); ++ car(vec+1+i)=obj; ++ cdr(vec+1+i)=obj; ++ } ++} ++ ++INTERFACE static pointer vector_elem(pointer vec, int ielem) { ++ int n=ielem/2; ++ if(ielem%2==0) { ++ return car(vec+1+n); ++ } else { ++ return cdr(vec+1+n); ++ } ++} ++ ++INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { ++ int n=ielem/2; ++ if(ielem%2==0) { ++ return car(vec+1+n)=a; ++ } else { ++ return cdr(vec+1+n)=a; ++ } ++} ++ ++/* get new symbol */ ++INTERFACE pointer mk_symbol(scheme *sc, const char *name) { ++ pointer x; ++ ++ /* first check oblist */ ++ x = oblist_find_by_name(sc, name); ++ if (x != sc->NIL) { ++ return (x); ++ } else { ++ x = oblist_add_by_name(sc, name); ++ return (x); ++ } ++} ++ ++INTERFACE pointer gensym(scheme *sc) { ++ pointer x; ++ char name[40]; ++ ++ for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) { ++ snprintf(name,40,"gensym-%ld",sc->gensym_cnt); ++ ++ /* first check oblist */ ++ x = oblist_find_by_name(sc, name); ++ ++ if (x != sc->NIL) { ++ continue; ++ } else { ++ x = oblist_add_by_name(sc, name); ++ return (x); ++ } ++ } ++ ++ return sc->NIL; ++} ++ ++/* make symbol or number atom from string */ ++static pointer mk_atom(scheme *sc, char *q) { ++ char c, *p; ++ int has_dec_point=0; ++ int has_fp_exp = 0; ++ ++#if USE_COLON_HOOK ++ if((p=strstr(q,"::"))!=0) { ++ *p=0; ++ return cons(sc, sc->COLON_HOOK, ++ cons(sc, ++ cons(sc, ++ sc->QUOTE, ++ cons(sc, mk_atom(sc,p+2), sc->NIL)), ++ cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL))); ++ } ++#endif ++ ++ p = q; ++ c = *p++; ++ if ((c == '+') || (c == '-')) { ++ c = *p++; ++ if (c == '.') { ++ has_dec_point=1; ++ c = *p++; ++ } ++ if (!isdigit(c)) { ++ return (mk_symbol(sc, strlwr(q))); ++ } ++ } else if (c == '.') { ++ has_dec_point=1; ++ c = *p++; ++ if (!isdigit(c)) { ++ return (mk_symbol(sc, strlwr(q))); ++ } ++ } else if (!isdigit(c)) { ++ return (mk_symbol(sc, strlwr(q))); ++ } ++ ++ for ( ; (c = *p) != 0; ++p) { ++ if (!isdigit(c)) { ++ if(c=='.') { ++ if(!has_dec_point) { ++ has_dec_point=1; ++ continue; ++ } ++ } ++ else if ((c == 'e') || (c == 'E')) { ++ if(!has_fp_exp) { ++ has_dec_point = 1; /* decimal point illegal ++ from now on */ ++ p++; ++ if ((*p == '-') || (*p == '+') || isdigit(*p)) { ++ continue; ++ } ++ } ++ } ++ return (mk_symbol(sc, strlwr(q))); ++ } ++ } ++ if(has_dec_point) { ++ return mk_real(sc,atof(q)); ++ } ++ return (mk_integer(sc, atol(q))); ++} ++ ++/* make constant */ ++static pointer mk_sharp_const(scheme *sc, char *name) { ++ long x; ++ char tmp[STRBUFFSIZE]; ++ ++ if (!strcmp(name, "t")) ++ return (sc->T); ++ else if (!strcmp(name, "f")) ++ return (sc->F); ++ else if (*name == 'o') {/* #o (octal) */ ++ snprintf(tmp, STRBUFFSIZE, "0%s", name+1); ++ sscanf(tmp, "%lo", (long unsigned *)&x); ++ return (mk_integer(sc, x)); ++ } else if (*name == 'd') { /* #d (decimal) */ ++ sscanf(name+1, "%ld", (long int *)&x); ++ return (mk_integer(sc, x)); ++ } else if (*name == 'x') { /* #x (hex) */ ++ snprintf(tmp, STRBUFFSIZE, "0x%s", name+1); ++ sscanf(tmp, "%lx", (long unsigned *)&x); ++ return (mk_integer(sc, x)); ++ } else if (*name == 'b') { /* #b (binary) */ ++ x = binary_decode(name+1); ++ return (mk_integer(sc, x)); ++ } else if (*name == '\\') { /* #\w (character) */ ++ int c=0; ++ if(stricmp(name+1,"space")==0) { ++ c=' '; ++ } else if(stricmp(name+1,"newline")==0) { ++ c='\n'; ++ } else if(stricmp(name+1,"return")==0) { ++ c='\r'; ++ } else if(stricmp(name+1,"tab")==0) { ++ c='\t'; ++ } else if(name[1]=='x' && name[2]!=0) { ++ int c1=0; ++ if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) { ++ c=c1; ++ } else { ++ return sc->NIL; ++ } ++#if USE_ASCII_NAMES ++ } else if(is_ascii_name(name+1,&c)) { ++ /* nothing */ ++#endif ++ } else if(name[2]==0) { ++ c=name[1]; ++ } else { ++ return sc->NIL; ++ } ++ return mk_character(sc,c); ++ } else ++ return (sc->NIL); ++} ++ ++/* ========== garbage collector ========== */ ++ ++/*-- ++ * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, ++ * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, ++ * for marking. ++ */ ++static void mark(pointer a) { ++ pointer t, q, p; ++ ++ t = (pointer) 0; ++ p = a; ++E2: setmark(p); ++ if(is_vector(p)) { ++ int i; ++ int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2; ++ for(i=0; i<num; i++) { ++ /* Vector cells will be treated like ordinary cells */ ++ mark(p+1+i); ++ } ++ } ++ if (is_atom(p)) ++ goto E6; ++ /* E4: down car */ ++ q = car(p); ++ if (q && !is_mark(q)) { ++ setatom(p); /* a note that we have moved car */ ++ car(p) = t; ++ t = p; ++ p = q; ++ goto E2; ++ } ++E5: q = cdr(p); /* down cdr */ ++ if (q && !is_mark(q)) { ++ cdr(p) = t; ++ t = p; ++ p = q; ++ goto E2; ++ } ++E6: /* up. Undo the link switching from steps E4 and E5. */ ++ if (!t) ++ return; ++ q = t; ++ if (is_atom(q)) { ++ clratom(q); ++ t = car(q); ++ car(q) = p; ++ p = q; ++ goto E5; ++ } else { ++ t = cdr(q); ++ cdr(q) = p; ++ p = q; ++ goto E6; ++ } ++} ++ ++/* garbage collection. parameter a, b is marked. */ ++static void gc(scheme *sc, pointer a, pointer b) { ++ pointer p; ++ int i; ++ ++ if(sc->gc_verbose) { ++ putstr(sc, "gc..."); ++ } ++ ++ /* mark system globals */ ++ mark(sc->oblist); ++ mark(sc->global_env); ++ ++ /* mark current registers */ ++ mark(sc->args); ++ mark(sc->envir); ++ mark(sc->code); ++ dump_stack_mark(sc); ++ mark(sc->value); ++ mark(sc->inport); ++ mark(sc->save_inport); ++ mark(sc->outport); ++ mark(sc->loadport); ++ ++ /* Mark recent objects the interpreter doesn't know about yet. */ ++ mark(car(sc->sink)); ++ /* Mark any older stuff above nested C calls */ ++ mark(sc->c_nest); ++ ++ /* mark variables a, b */ ++ mark(a); ++ mark(b); ++ ++ /* garbage collect */ ++ clrmark(sc->NIL); ++ sc->fcells = 0; ++ sc->free_cell = sc->NIL; ++ /* free-list is kept sorted by address so as to maintain consecutive ++ ranges, if possible, for use with vectors. Here we scan the cells ++ (which are also kept sorted by address) downwards to build the ++ free-list in sorted order. ++ */ ++ for (i = sc->last_cell_seg; i >= 0; i--) { ++ p = sc->cell_seg[i] + CELL_SEGSIZE; ++ while (--p >= sc->cell_seg[i]) { ++ if (is_mark(p)) { ++ clrmark(p); ++ } else { ++ /* reclaim cell */ ++ if (typeflag(p) != 0) { ++ finalize_cell(sc, p); ++ typeflag(p) = 0; ++ car(p) = sc->NIL; ++ } ++ ++sc->fcells; ++ cdr(p) = sc->free_cell; ++ sc->free_cell = p; ++ } ++ } ++ } ++ ++ if (sc->gc_verbose) { ++ char msg[80]; ++ snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells); ++ putstr(sc,msg); ++ } ++} ++ ++static void finalize_cell(scheme *sc, pointer a) { ++ if(is_string(a)) { ++ sc->free(strvalue(a)); ++ } else if(is_port(a)) { ++ if(a->_object._port->kind&port_file ++ && a->_object._port->rep.stdio.closeit) { ++ port_close(sc,a,port_input|port_output); ++ } ++ sc->free(a->_object._port); ++ } ++} ++ ++/* ========== Routines for Reading ========== */ ++ ++static int file_push(scheme *sc, const char *fname) { ++ FILE *fin = NULL; ++ ++ if (sc->file_i == MAXFIL-1) ++ return 0; ++ fin=fopen(fname,"r"); ++ if(fin!=0) { ++ sc->file_i++; ++ sc->load_stack[sc->file_i].kind=port_file|port_input; ++ sc->load_stack[sc->file_i].rep.stdio.file=fin; ++ sc->load_stack[sc->file_i].rep.stdio.closeit=1; ++ sc->nesting_stack[sc->file_i]=0; ++ sc->loadport->_object._port=sc->load_stack+sc->file_i; ++ ++#if SHOW_ERROR_LINE ++ sc->load_stack[sc->file_i].rep.stdio.curr_line = 0; ++ if(fname) ++ sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0); ++#endif ++ } ++ return fin!=0; ++} ++ ++static void file_pop(scheme *sc) { ++ if(sc->file_i != 0) { ++ sc->nesting=sc->nesting_stack[sc->file_i]; ++ port_close(sc,sc->loadport,port_input); ++ sc->file_i--; ++ sc->loadport->_object._port=sc->load_stack+sc->file_i; ++ } ++} ++ ++static int file_interactive(scheme *sc) { ++ return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin ++ && sc->inport->_object._port->kind&port_file; ++} ++ ++static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { ++ FILE *f; ++ char *rw; ++ port *pt; ++ if(prop==(port_input|port_output)) { ++ rw="a+"; ++ } else if(prop==port_output) { ++ rw="w"; ++ } else { ++ rw="r"; ++ } ++ f=fopen(fn,rw); ++ if(f==0) { ++ return 0; ++ } ++ pt=port_rep_from_file(sc,f,prop); ++ pt->rep.stdio.closeit=1; ++ ++#if SHOW_ERROR_LINE ++ if(fn) ++ pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0); ++ ++ pt->rep.stdio.curr_line = 0; ++#endif ++ return pt; ++} ++ ++static pointer port_from_filename(scheme *sc, const char *fn, int prop) { ++ port *pt; ++ pt=port_rep_from_filename(sc,fn,prop); ++ if(pt==0) { ++ return sc->NIL; ++ } ++ return mk_port(sc,pt); ++} ++ ++static port *port_rep_from_file(scheme *sc, FILE *f, int prop) ++{ ++ port *pt; ++ ++ pt = (port *)sc->malloc(sizeof *pt); ++ if (pt == NULL) { ++ return NULL; ++ } ++ pt->kind = port_file | prop; ++ pt->rep.stdio.file = f; ++ pt->rep.stdio.closeit = 0; ++ return pt; ++} ++ ++static pointer port_from_file(scheme *sc, FILE *f, int prop) { ++ port *pt; ++ pt=port_rep_from_file(sc,f,prop); ++ if(pt==0) { ++ return sc->NIL; ++ } ++ return mk_port(sc,pt); ++} ++ ++static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) { ++ port *pt; ++ pt=(port*)sc->malloc(sizeof(port)); ++ if(pt==0) { ++ return 0; ++ } ++ pt->kind=port_string|prop; ++ pt->rep.string.start=start; ++ pt->rep.string.curr=start; ++ pt->rep.string.past_the_end=past_the_end; ++ return pt; ++} ++ ++static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) { ++ port *pt; ++ pt=port_rep_from_string(sc,start,past_the_end,prop); ++ if(pt==0) { ++ return sc->NIL; ++ } ++ return mk_port(sc,pt); ++} ++ ++#define BLOCK_SIZE 256 ++ ++static port *port_rep_from_scratch(scheme *sc) { ++ port *pt; ++ char *start; ++ pt=(port*)sc->malloc(sizeof(port)); ++ if(pt==0) { ++ return 0; ++ } ++ start=sc->malloc(BLOCK_SIZE); ++ if(start==0) { ++ return 0; ++ } ++ memset(start,' ',BLOCK_SIZE-1); ++ start[BLOCK_SIZE-1]='\0'; ++ pt->kind=port_string|port_output|port_srfi6; ++ pt->rep.string.start=start; ++ pt->rep.string.curr=start; ++ pt->rep.string.past_the_end=start+BLOCK_SIZE-1; ++ return pt; ++} ++ ++static pointer port_from_scratch(scheme *sc) { ++ port *pt; ++ pt=port_rep_from_scratch(sc); ++ if(pt==0) { ++ return sc->NIL; ++ } ++ return mk_port(sc,pt); ++} ++ ++static void port_close(scheme *sc, pointer p, int flag) { ++ port *pt=p->_object._port; ++ pt->kind&=~flag; ++ if((pt->kind & (port_input|port_output))==0) { ++ if(pt->kind&port_file) { ++ ++#if SHOW_ERROR_LINE ++ /* Cleanup is here so (close-*-port) functions could work too */ ++ pt->rep.stdio.curr_line = 0; ++ ++ if(pt->rep.stdio.filename) ++ sc->free(pt->rep.stdio.filename); ++#endif ++ ++ fclose(pt->rep.stdio.file); ++ } ++ pt->kind=port_free; ++ } ++} ++ ++/* get new character from input file */ ++static int inchar(scheme *sc) { ++ int c; ++ port *pt; ++ ++ pt = sc->inport->_object._port; ++ if(pt->kind & port_saw_EOF) ++ { return EOF; } ++ c = basic_inchar(pt); ++ if(c == EOF && sc->inport == sc->loadport) { ++ /* Instead, set port_saw_EOF */ ++ pt->kind |= port_saw_EOF; ++ ++ /* file_pop(sc); */ ++ return EOF; ++ /* NOTREACHED */ ++ } ++ return c; ++} ++ ++static int basic_inchar(port *pt) { ++ if(pt->kind & port_file) { ++ return fgetc(pt->rep.stdio.file); ++ } else { ++ if(*pt->rep.string.curr == 0 || ++ pt->rep.string.curr == pt->rep.string.past_the_end) { ++ return EOF; ++ } else { ++ return *pt->rep.string.curr++; ++ } ++ } ++} ++ ++/* back character to input buffer */ ++static void backchar(scheme *sc, int c) { ++ port *pt; ++ if(c==EOF) return; ++ pt=sc->inport->_object._port; ++ if(pt->kind&port_file) { ++ ungetc(c,pt->rep.stdio.file); ++ } else { ++ if(pt->rep.string.curr!=pt->rep.string.start) { ++ --pt->rep.string.curr; ++ } ++ } ++} ++ ++static int realloc_port_string(scheme *sc, port *p) ++{ ++ char *start=p->rep.string.start; ++ size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE; ++ char *str=sc->malloc(new_size); ++ if(str) { ++ memset(str,' ',new_size-1); ++ str[new_size-1]='\0'; ++ strcpy(str,start); ++ p->rep.string.start=str; ++ p->rep.string.past_the_end=str+new_size-1; ++ p->rep.string.curr-=start-str; ++ sc->free(start); ++ return 1; ++ } else { ++ return 0; ++ } ++} ++ ++INTERFACE void putstr(scheme *sc, const char *s) { ++ port *pt=sc->outport->_object._port; ++ if(pt->kind&port_file) { ++ fputs(s,pt->rep.stdio.file); ++ } else { ++ for(;*s;s++) { ++ if(pt->rep.string.curr!=pt->rep.string.past_the_end) { ++ *pt->rep.string.curr++=*s; ++ } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { ++ *pt->rep.string.curr++=*s; ++ } ++ } ++ } ++} ++ ++static void putchars(scheme *sc, const char *s, int len) { ++ port *pt=sc->outport->_object._port; ++ if(pt->kind&port_file) { ++ fwrite(s,1,len,pt->rep.stdio.file); ++ } else { ++ for(;len;len--) { ++ if(pt->rep.string.curr!=pt->rep.string.past_the_end) { ++ *pt->rep.string.curr++=*s++; ++ } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { ++ *pt->rep.string.curr++=*s++; ++ } ++ } ++ } ++} ++ ++INTERFACE void putcharacter(scheme *sc, int c) { ++ port *pt=sc->outport->_object._port; ++ if(pt->kind&port_file) { ++ fputc(c,pt->rep.stdio.file); ++ } else { ++ if(pt->rep.string.curr!=pt->rep.string.past_the_end) { ++ *pt->rep.string.curr++=c; ++ } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { ++ *pt->rep.string.curr++=c; ++ } ++ } ++} ++ ++/* read characters up to delimiter, but cater to character constants */ ++static char *readstr_upto(scheme *sc, char *delim) { ++ char *p = sc->strbuff; ++ ++ while ((p - sc->strbuff < sizeof(sc->strbuff)) && ++ !is_one_of(delim, (*p++ = inchar(sc)))); ++ ++ if(p == sc->strbuff+2 && p[-2] == '\\') { ++ *p=0; ++ } else { ++ backchar(sc,p[-1]); ++ *--p = '\0'; ++ } ++ return sc->strbuff; ++} ++ ++/* read string expression "xxx...xxx" */ ++static pointer readstrexp(scheme *sc) { ++ char *p = sc->strbuff; ++ int c; ++ int c1=0; ++ enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok; ++ ++ for (;;) { ++ c=inchar(sc); ++ if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) { ++ return sc->F; ++ } ++ switch(state) { ++ case st_ok: ++ switch(c) { ++ case '\\': ++ state=st_bsl; ++ break; ++ case '"': ++ *p=0; ++ return mk_counted_string(sc,sc->strbuff,p-sc->strbuff); ++ default: ++ *p++=c; ++ break; ++ } ++ break; ++ case st_bsl: ++ switch(c) { ++ case '0': ++ case '1': ++ case '2': ++ case '3': ++ case '4': ++ case '5': ++ case '6': ++ case '7': ++ state=st_oct1; ++ c1=c-'0'; ++ break; ++ case 'x': ++ case 'X': ++ state=st_x1; ++ c1=0; ++ break; ++ case 'n': ++ *p++='\n'; ++ state=st_ok; ++ break; ++ case 't': ++ *p++='\t'; ++ state=st_ok; ++ break; ++ case 'r': ++ *p++='\r'; ++ state=st_ok; ++ break; ++ case '"': ++ *p++='"'; ++ state=st_ok; ++ break; ++ default: ++ *p++=c; ++ state=st_ok; ++ break; ++ } ++ break; ++ case st_x1: ++ case st_x2: ++ c=toupper(c); ++ if(c>='0' && c<='F') { ++ if(c<='9') { ++ c1=(c1<<4)+c-'0'; ++ } else { ++ c1=(c1<<4)+c-'A'+10; ++ } ++ if(state==st_x1) { ++ state=st_x2; ++ } else { ++ *p++=c1; ++ state=st_ok; ++ } ++ } else { ++ return sc->F; ++ } ++ break; ++ case st_oct1: ++ case st_oct2: ++ if (c < '0' || c > '7') ++ { ++ *p++=c1; ++ backchar(sc, c); ++ state=st_ok; ++ } ++ else ++ { ++ if (state==st_oct2 && c1 >= 32) ++ return sc->F; ++ ++ c1=(c1<<3)+(c-'0'); ++ ++ if (state == st_oct1) ++ state=st_oct2; ++ else ++ { ++ *p++=c1; ++ state=st_ok; ++ } ++ } ++ break; ++ ++ } ++ } ++} ++ ++/* check c is in chars */ ++static INLINE int is_one_of(char *s, int c) { ++ if(c==EOF) return 1; ++ while (*s) ++ if (*s++ == c) ++ return (1); ++ return (0); ++} ++ ++/* skip white characters */ ++static INLINE int skipspace(scheme *sc) { ++ int c = 0, curr_line = 0; ++ ++ do { ++ c=inchar(sc); ++#if SHOW_ERROR_LINE ++ if(c=='\n') ++ curr_line++; ++#endif ++ } while (isspace(c)); ++ ++/* record it */ ++#if SHOW_ERROR_LINE ++ if (sc->load_stack[sc->file_i].kind & port_file) ++ sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line; ++#endif ++ ++ if(c!=EOF) { ++ backchar(sc,c); ++ return 1; ++ } ++ else ++ { return EOF; } ++} ++ ++/* get token */ ++static int token(scheme *sc) { ++ int c; ++ c = skipspace(sc); ++ if(c == EOF) { return (TOK_EOF); } ++ switch (c=inchar(sc)) { ++ case EOF: ++ return (TOK_EOF); ++ case '(': ++ return (TOK_LPAREN); ++ case ')': ++ return (TOK_RPAREN); ++ case '.': ++ c=inchar(sc); ++ if(is_one_of(" \n\t",c)) { ++ return (TOK_DOT); ++ } else { ++ backchar(sc,c); ++ backchar(sc,'.'); ++ return TOK_ATOM; ++ } ++ case '\'': ++ return (TOK_QUOTE); ++ case ';': ++ while ((c=inchar(sc)) != '\n' && c!=EOF) ++ ; ++ ++#if SHOW_ERROR_LINE ++ if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) ++ sc->load_stack[sc->file_i].rep.stdio.curr_line++; ++#endif ++ ++ if(c == EOF) ++ { return (TOK_EOF); } ++ else ++ { return (token(sc));} ++ case '"': ++ return (TOK_DQUOTE); ++ case BACKQUOTE: ++ return (TOK_BQUOTE); ++ case ',': ++ if ((c=inchar(sc)) == '@') { ++ return (TOK_ATMARK); ++ } else { ++ backchar(sc,c); ++ return (TOK_COMMA); ++ } ++ case '#': ++ c=inchar(sc); ++ if (c == '(') { ++ return (TOK_VEC); ++ } else if(c == '!') { ++ while ((c=inchar(sc)) != '\n' && c!=EOF) ++ ; ++ ++#if SHOW_ERROR_LINE ++ if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) ++ sc->load_stack[sc->file_i].rep.stdio.curr_line++; ++#endif ++ ++ if(c == EOF) ++ { return (TOK_EOF); } ++ else ++ { return (token(sc));} ++ } else { ++ backchar(sc,c); ++ if(is_one_of(" tfodxb\\",c)) { ++ return TOK_SHARP_CONST; ++ } else { ++ return (TOK_SHARP); ++ } ++ } ++ default: ++ backchar(sc,c); ++ return (TOK_ATOM); ++ } ++} ++ ++/* ========== Routines for Printing ========== */ ++#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL) ++ ++static void printslashstring(scheme *sc, char *p, int len) { ++ int i; ++ unsigned char *s=(unsigned char*)p; ++ putcharacter(sc,'"'); ++ for ( i=0; i<len; i++) { ++ if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') { ++ putcharacter(sc,'\\'); ++ switch(*s) { ++ case '"': ++ putcharacter(sc,'"'); ++ break; ++ case '\n': ++ putcharacter(sc,'n'); ++ break; ++ case '\t': ++ putcharacter(sc,'t'); ++ break; ++ case '\r': ++ putcharacter(sc,'r'); ++ break; ++ case '\\': ++ putcharacter(sc,'\\'); ++ break; ++ default: { ++ int d=*s/16; ++ putcharacter(sc,'x'); ++ if(d<10) { ++ putcharacter(sc,d+'0'); ++ } else { ++ putcharacter(sc,d-10+'A'); ++ } ++ d=*s%16; ++ if(d<10) { ++ putcharacter(sc,d+'0'); ++ } else { ++ putcharacter(sc,d-10+'A'); ++ } ++ } ++ } ++ } else { ++ putcharacter(sc,*s); ++ } ++ s++; ++ } ++ putcharacter(sc,'"'); ++} ++ ++ ++/* print atoms */ ++static void printatom(scheme *sc, pointer l, int f) { ++ char *p; ++ int len; ++ atom2str(sc,l,f,&p,&len); ++ putchars(sc,p,len); ++} ++ ++ ++/* Uses internal buffer unless string pointer is already available */ ++static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) { ++ char *p; ++ ++ if (l == sc->NIL) { ++ p = "()"; ++ } else if (l == sc->T) { ++ p = "#t"; ++ } else if (l == sc->F) { ++ p = "#f"; ++ } else if (l == sc->EOF_OBJ) { ++ p = "#<EOF>"; ++ } else if (is_port(l)) { ++ p = sc->strbuff; ++ snprintf(p, STRBUFFSIZE, "#<PORT>"); ++ } else if (is_number(l)) { ++ p = sc->strbuff; ++ if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ { ++ if(num_is_integer(l)) { ++ snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l)); ++ } else { ++ snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l)); ++ /* r5rs says there must be a '.' (unless 'e'?) */ ++ f = strcspn(p, ".e"); ++ if (p[f] == 0) { ++ p[f] = '.'; /* not found, so add '.0' at the end */ ++ p[f+1] = '0'; ++ p[f+2] = 0; ++ } ++ } ++ } else { ++ long v = ivalue(l); ++ if (f == 16) { ++ if (v >= 0) ++ snprintf(p, STRBUFFSIZE, "%lx", v); ++ else ++ snprintf(p, STRBUFFSIZE, "-%lx", -v); ++ } else if (f == 8) { ++ if (v >= 0) ++ snprintf(p, STRBUFFSIZE, "%lo", v); ++ else ++ snprintf(p, STRBUFFSIZE, "-%lo", -v); ++ } else if (f == 2) { ++ unsigned long b = (v < 0) ? -v : v; ++ p = &p[STRBUFFSIZE-1]; ++ *p = 0; ++ do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0); ++ if (v < 0) *--p = '-'; ++ } ++ } ++ } else if (is_string(l)) { ++ if (!f) { ++ p = strvalue(l); ++ } else { /* Hack, uses the fact that printing is needed */ ++ *pp=sc->strbuff; ++ *plen=0; ++ printslashstring(sc, strvalue(l), strlength(l)); ++ return; ++ } ++ } else if (is_character(l)) { ++ int c=charvalue(l); ++ p = sc->strbuff; ++ if (!f) { ++ p[0]=c; ++ p[1]=0; ++ } else { ++ switch(c) { ++ case ' ': ++ snprintf(p,STRBUFFSIZE,"#\\space"); break; ++ case '\n': ++ snprintf(p,STRBUFFSIZE,"#\\newline"); break; ++ case '\r': ++ snprintf(p,STRBUFFSIZE,"#\\return"); break; ++ case '\t': ++ snprintf(p,STRBUFFSIZE,"#\\tab"); break; ++ default: ++#if USE_ASCII_NAMES ++ if(c==127) { ++ snprintf(p,STRBUFFSIZE, "#\\del"); ++ break; ++ } else if(c<32) { ++ snprintf(p, STRBUFFSIZE, "#\\%s", charnames[c]); ++ break; ++ } ++#else ++ if(c<32) { ++ snprintf(p,STRBUFFSIZE,"#\\x%x",c); break; ++ break; ++ } ++#endif ++ snprintf(p,STRBUFFSIZE,"#\\%c",c); break; ++ break; ++ } ++ } ++ } else if (is_symbol(l)) { ++ p = symname(l); ++ } else if (is_proc(l)) { ++ p = sc->strbuff; ++ snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l)); ++ } else if (is_macro(l)) { ++ p = "#<MACRO>"; ++ } else if (is_closure(l)) { ++ p = "#<CLOSURE>"; ++ } else if (is_promise(l)) { ++ p = "#<PROMISE>"; ++ } else if (is_foreign(l)) { ++ p = sc->strbuff; ++ snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l)); ++ } else if (is_continuation(l)) { ++ p = "#<CONTINUATION>"; ++ } else { ++ p = "#<ERROR>"; ++ } ++ *pp=p; ++ *plen=strlen(p); ++} ++/* ========== Routines for Evaluation Cycle ========== */ ++ ++/* make closure. c is code. e is environment */ ++static pointer mk_closure(scheme *sc, pointer c, pointer e) { ++ pointer x = get_cell(sc, c, e); ++ ++ typeflag(x) = T_CLOSURE; ++ car(x) = c; ++ cdr(x) = e; ++ return (x); ++} ++ ++/* make continuation. */ ++static pointer mk_continuation(scheme *sc, pointer d) { ++ pointer x = get_cell(sc, sc->NIL, d); ++ ++ typeflag(x) = T_CONTINUATION; ++ cont_dump(x) = d; ++ return (x); ++} ++ ++static pointer list_star(scheme *sc, pointer d) { ++ pointer p, q; ++ if(cdr(d)==sc->NIL) { ++ return car(d); ++ } ++ p=cons(sc,car(d),cdr(d)); ++ q=p; ++ while(cdr(cdr(p))!=sc->NIL) { ++ d=cons(sc,car(p),cdr(p)); ++ if(cdr(cdr(p))!=sc->NIL) { ++ p=cdr(d); ++ } ++ } ++ cdr(p)=car(cdr(p)); ++ return q; ++} ++ ++/* reverse list -- produce new list */ ++static pointer reverse(scheme *sc, pointer a) { ++/* a must be checked by gc */ ++ pointer p = sc->NIL; ++ ++ for ( ; is_pair(a); a = cdr(a)) { ++ p = cons(sc, car(a), p); ++ } ++ return (p); ++} ++ ++/* reverse list --- in-place */ ++static pointer reverse_in_place(scheme *sc, pointer term, pointer list) { ++ pointer p = list, result = term, q; ++ ++ while (p != sc->NIL) { ++ q = cdr(p); ++ cdr(p) = result; ++ result = p; ++ p = q; ++ } ++ return (result); ++} ++ ++/* append list -- produce new list (in reverse order) */ ++static pointer revappend(scheme *sc, pointer a, pointer b) { ++ pointer result = a; ++ pointer p = b; ++ ++ while (is_pair(p)) { ++ result = cons(sc, car(p), result); ++ p = cdr(p); ++ } ++ ++ if (p == sc->NIL) { ++ return result; ++ } ++ ++ return sc->F; /* signal an error */ ++} ++ ++/* equivalence of atoms */ ++int eqv(pointer a, pointer b) { ++ if (is_string(a)) { ++ if (is_string(b)) ++ return (strvalue(a) == strvalue(b)); ++ else ++ return (0); ++ } else if (is_number(a)) { ++ if (is_number(b)) { ++ if (num_is_integer(a) == num_is_integer(b)) ++ return num_eq(nvalue(a),nvalue(b)); ++ } ++ return (0); ++ } else if (is_character(a)) { ++ if (is_character(b)) ++ return charvalue(a)==charvalue(b); ++ else ++ return (0); ++ } else if (is_port(a)) { ++ if (is_port(b)) ++ return a==b; ++ else ++ return (0); ++ } else if (is_proc(a)) { ++ if (is_proc(b)) ++ return procnum(a)==procnum(b); ++ else ++ return (0); ++ } else { ++ return (a == b); ++ } ++} ++ ++/* true or false value macro */ ++/* () is #t in R5RS */ ++#define is_true(p) ((p) != sc->F) ++#define is_false(p) ((p) == sc->F) ++ ++/* ========== Environment implementation ========== */ ++ ++#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) ++ ++static int hash_fn(const char *key, int table_size) ++{ ++ unsigned int hashed = 0; ++ const char *c; ++ int bits_per_int = sizeof(unsigned int)*8; ++ ++ for (c = key; *c; c++) { ++ /* letters have about 5 bits in them */ ++ hashed = (hashed<<5) | (hashed>>(bits_per_int-5)); ++ hashed ^= *c; ++ } ++ return hashed % table_size; ++} ++#endif ++ ++#ifndef USE_ALIST_ENV ++ ++/* ++ * In this implementation, each frame of the environment may be ++ * a hash table: a vector of alists hashed by variable name. ++ * In practice, we use a vector only for the initial frame; ++ * subsequent frames are too small and transient for the lookup ++ * speed to out-weigh the cost of making a new vector. ++ */ ++ ++static void new_frame_in_env(scheme *sc, pointer old_env) ++{ ++ pointer new_frame; ++ ++ /* The interaction-environment has about 300 variables in it. */ ++ if (old_env == sc->NIL) { ++ new_frame = mk_vector(sc, 461); ++ } else { ++ new_frame = sc->NIL; ++ } ++ ++ sc->envir = immutable_cons(sc, new_frame, old_env); ++ setenvironment(sc->envir); ++} ++ ++static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, ++ pointer variable, pointer value) ++{ ++ pointer slot = immutable_cons(sc, variable, value); ++ ++ if (is_vector(car(env))) { ++ int location = hash_fn(symname(variable), ivalue_unchecked(car(env))); ++ ++ set_vector_elem(car(env), location, ++ immutable_cons(sc, slot, vector_elem(car(env), location))); ++ } else { ++ car(env) = immutable_cons(sc, slot, car(env)); ++ } ++} ++ ++static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) ++{ ++ pointer x,y; ++ int location; ++ ++ for (x = env; x != sc->NIL; x = cdr(x)) { ++ if (is_vector(car(x))) { ++ location = hash_fn(symname(hdl), ivalue_unchecked(car(x))); ++ y = vector_elem(car(x), location); ++ } else { ++ y = car(x); ++ } ++ for ( ; y != sc->NIL; y = cdr(y)) { ++ if (caar(y) == hdl) { ++ break; ++ } ++ } ++ if (y != sc->NIL) { ++ break; ++ } ++ if(!all) { ++ return sc->NIL; ++ } ++ } ++ if (x != sc->NIL) { ++ return car(y); ++ } ++ return sc->NIL; ++} ++ ++#else /* USE_ALIST_ENV */ ++ ++static INLINE void new_frame_in_env(scheme *sc, pointer old_env) ++{ ++ sc->envir = immutable_cons(sc, sc->NIL, old_env); ++ setenvironment(sc->envir); ++} ++ ++static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, ++ pointer variable, pointer value) ++{ ++ car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env)); ++} ++ ++static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) ++{ ++ pointer x,y; ++ for (x = env; x != sc->NIL; x = cdr(x)) { ++ for (y = car(x); y != sc->NIL; y = cdr(y)) { ++ if (caar(y) == hdl) { ++ break; ++ } ++ } ++ if (y != sc->NIL) { ++ break; ++ } ++ if(!all) { ++ return sc->NIL; ++ } ++ } ++ if (x != sc->NIL) { ++ return car(y); ++ } ++ return sc->NIL; ++} ++ ++#endif /* USE_ALIST_ENV else */ ++ ++static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) ++{ ++ new_slot_spec_in_env(sc, sc->envir, variable, value); ++} ++ ++static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) ++{ ++ cdr(slot) = value; ++} ++ ++static INLINE pointer slot_value_in_env(pointer slot) ++{ ++ return cdr(slot); ++} ++ ++/* ========== Evaluation Cycle ========== */ ++ ++ ++static pointer _Error_1(scheme *sc, const char *s, pointer a) { ++ const char *str = s; ++#if USE_ERROR_HOOK ++ pointer x; ++ pointer hdl=sc->ERROR_HOOK; ++#endif ++ ++#if SHOW_ERROR_LINE ++ char sbuf[STRBUFFSIZE]; ++ ++ /* make sure error is not in REPL */ ++ if (sc->load_stack[sc->file_i].kind & port_file && ++ sc->load_stack[sc->file_i].rep.stdio.file != stdin) { ++ int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line; ++ const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename; ++ ++ /* should never happen */ ++ if(!fname) fname = "<unknown>"; ++ ++ /* we started from 0 */ ++ ln++; ++ snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s); ++ ++ str = (const char*)sbuf; ++ } ++#endif ++ ++#if USE_ERROR_HOOK ++ x=find_slot_in_env(sc,sc->envir,hdl,1); ++ if (x != sc->NIL) { ++ if(a!=0) { ++ sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL); ++ } else { ++ sc->code = sc->NIL; ++ } ++ sc->code = cons(sc, mk_string(sc, str), sc->code); ++ setimmutable(car(sc->code)); ++ sc->code = cons(sc, slot_value_in_env(x), sc->code); ++ sc->op = (int)OP_EVAL; ++ return sc->T; ++ } ++#endif ++ ++ if(a!=0) { ++ sc->args = cons(sc, (a), sc->NIL); ++ } else { ++ sc->args = sc->NIL; ++ } ++ sc->args = cons(sc, mk_string(sc, str), sc->args); ++ setimmutable(car(sc->args)); ++ sc->op = (int)OP_ERR0; ++ return sc->T; ++} ++#define Error_1(sc,s, a) return _Error_1(sc,s,a) ++#define Error_0(sc,s) return _Error_1(sc,s,0) ++ ++/* Too small to turn into function */ ++# define BEGIN do { ++# define END } while (0) ++#define s_goto(sc,a) BEGIN \ ++ sc->op = (int)(a); \ ++ return sc->T; END ++ ++#define s_return(sc,a) return _s_return(sc,a) ++ ++#ifndef USE_SCHEME_STACK ++ ++/* this structure holds all the interpreter's registers */ ++struct dump_stack_frame { ++ enum scheme_opcodes op; ++ pointer args; ++ pointer envir; ++ pointer code; ++}; ++ ++#define STACK_GROWTH 3 ++ ++static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) ++{ ++ int nframes = (int)sc->dump; ++ struct dump_stack_frame *next_frame; ++ ++ /* enough room for the next frame? */ ++ if (nframes >= sc->dump_size) { ++ sc->dump_size += STACK_GROWTH; ++ /* alas there is no sc->realloc */ ++ sc->dump_base = realloc(sc->dump_base, ++ sizeof(struct dump_stack_frame) * sc->dump_size); ++ } ++ next_frame = (struct dump_stack_frame *)sc->dump_base + nframes; ++ next_frame->op = op; ++ next_frame->args = args; ++ next_frame->envir = sc->envir; ++ next_frame->code = code; ++ sc->dump = (pointer)(nframes+1); ++} ++ ++static pointer _s_return(scheme *sc, pointer a) ++{ ++ int nframes = (int)sc->dump; ++ struct dump_stack_frame *frame; ++ ++ sc->value = (a); ++ if (nframes <= 0) { ++ return sc->NIL; ++ } ++ nframes--; ++ frame = (struct dump_stack_frame *)sc->dump_base + nframes; ++ sc->op = frame->op; ++ sc->args = frame->args; ++ sc->envir = frame->envir; ++ sc->code = frame->code; ++ sc->dump = (pointer)nframes; ++ return sc->T; ++} ++ ++static INLINE void dump_stack_reset(scheme *sc) ++{ ++ /* in this implementation, sc->dump is the number of frames on the stack */ ++ sc->dump = (pointer)0; ++} ++ ++static INLINE void dump_stack_initialize(scheme *sc) ++{ ++ sc->dump_size = 0; ++ sc->dump_base = NULL; ++ dump_stack_reset(sc); ++} ++ ++static void dump_stack_free(scheme *sc) ++{ ++ free(sc->dump_base); ++ sc->dump_base = NULL; ++ sc->dump = (pointer)0; ++ sc->dump_size = 0; ++} ++ ++static INLINE void dump_stack_mark(scheme *sc) ++{ ++ int nframes = (int)sc->dump; ++ int i; ++ for(i=0; i<nframes; i++) { ++ struct dump_stack_frame *frame; ++ frame = (struct dump_stack_frame *)sc->dump_base + i; ++ mark(frame->args); ++ mark(frame->envir); ++ mark(frame->code); ++ } ++} ++ ++#else ++ ++static INLINE void dump_stack_reset(scheme *sc) ++{ ++ sc->dump = sc->NIL; ++} ++ ++static INLINE void dump_stack_initialize(scheme *sc) ++{ ++ dump_stack_reset(sc); ++} ++ ++static void dump_stack_free(scheme *sc) ++{ ++ sc->dump = sc->NIL; ++} ++ ++static pointer _s_return(scheme *sc, pointer a) { ++ sc->value = (a); ++ if(sc->dump==sc->NIL) return sc->NIL; ++ sc->op = ivalue(car(sc->dump)); ++ sc->args = cadr(sc->dump); ++ sc->envir = caddr(sc->dump); ++ sc->code = cadddr(sc->dump); ++ sc->dump = cddddr(sc->dump); ++ return sc->T; ++} ++ ++static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { ++ sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); ++ sc->dump = cons(sc, (args), sc->dump); ++ sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump); ++} ++ ++static INLINE void dump_stack_mark(scheme *sc) ++{ ++ mark(sc->dump); ++} ++#endif ++ ++#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) ++ ++static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { ++ pointer x, y; ++ ++ switch (op) { ++ case OP_LOAD: /* load */ ++ if(file_interactive(sc)) { ++ fprintf(sc->outport->_object._port->rep.stdio.file, ++ "Loading %s\n", strvalue(car(sc->args))); ++ } ++ if (!file_push(sc,strvalue(car(sc->args)))) { ++ Error_1(sc,"unable to open", car(sc->args)); ++ } ++ else ++ { ++ sc->args = mk_integer(sc,sc->file_i); ++ s_goto(sc,OP_T0LVL); ++ } ++ ++ case OP_T0LVL: /* top level */ ++ /* If we reached the end of file, this loop is done. */ ++ if(sc->loadport->_object._port->kind & port_saw_EOF) ++ { ++ if(sc->file_i == 0) ++ { ++ sc->args=sc->NIL; ++ s_goto(sc,OP_QUIT); ++ } ++ else ++ { ++ file_pop(sc); ++ s_return(sc,sc->value); ++ } ++ /* NOTREACHED */ ++ } ++ ++ /* If interactive, be nice to user. */ ++ if(file_interactive(sc)) ++ { ++ sc->envir = sc->global_env; ++ dump_stack_reset(sc); ++ putstr(sc,"\n"); ++ putstr(sc,prompt); ++ } ++ ++ /* Set up another iteration of REPL */ ++ sc->nesting=0; ++ sc->save_inport=sc->inport; ++ sc->inport = sc->loadport; ++ s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); ++ s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); ++ s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); ++ s_goto(sc,OP_READ_INTERNAL); ++ ++ case OP_T1LVL: /* top level */ ++ sc->code = sc->value; ++ sc->inport=sc->save_inport; ++ s_goto(sc,OP_EVAL); ++ ++ case OP_READ_INTERNAL: /* internal read */ ++ sc->tok = token(sc); ++ if(sc->tok==TOK_EOF) ++ { s_return(sc,sc->EOF_OBJ); } ++ s_goto(sc,OP_RDSEXPR); ++ ++ case OP_GENSYM: ++ s_return(sc, gensym(sc)); ++ ++ case OP_VALUEPRINT: /* print evaluation result */ ++ /* OP_VALUEPRINT is always pushed, because when changing from ++ non-interactive to interactive mode, it needs to be ++ already on the stack */ ++ if(sc->tracing) { ++ putstr(sc,"\nGives: "); ++ } ++ if(file_interactive(sc)) { ++ sc->print_flag = 1; ++ sc->args = sc->value; ++ s_goto(sc,OP_P0LIST); ++ } else { ++ s_return(sc,sc->value); ++ } ++ ++ case OP_EVAL: /* main part of evaluation */ ++#if USE_TRACING ++ if(sc->tracing) { ++ /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ ++ s_save(sc,OP_REAL_EVAL,sc->args,sc->code); ++ sc->args=sc->code; ++ putstr(sc,"\nEval: "); ++ s_goto(sc,OP_P0LIST); ++ } ++ /* fall through */ ++ case OP_REAL_EVAL: ++#endif ++ if (is_symbol(sc->code)) { /* symbol */ ++ x=find_slot_in_env(sc,sc->envir,sc->code,1); ++ if (x != sc->NIL) { ++ s_return(sc,slot_value_in_env(x)); ++ } else { ++ Error_1(sc,"eval: unbound variable:", sc->code); ++ } ++ } else if (is_pair(sc->code)) { ++ if (is_syntax(x = car(sc->code))) { /* SYNTAX */ ++ sc->code = cdr(sc->code); ++ s_goto(sc,syntaxnum(x)); ++ } else {/* first, eval top element and eval arguments */ ++ s_save(sc,OP_E0ARGS, sc->NIL, sc->code); ++ /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ } ++ } else { ++ s_return(sc,sc->code); ++ } ++ ++ case OP_E0ARGS: /* eval arguments */ ++ if (is_macro(sc->value)) { /* macro expansion */ ++ s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); ++ sc->args = cons(sc,sc->code, sc->NIL); ++ sc->code = sc->value; ++ s_goto(sc,OP_APPLY); ++ } else { ++ sc->code = cdr(sc->code); ++ s_goto(sc,OP_E1ARGS); ++ } ++ ++ case OP_E1ARGS: /* eval arguments */ ++ sc->args = cons(sc, sc->value, sc->args); ++ if (is_pair(sc->code)) { /* continue */ ++ s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); ++ sc->code = car(sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_EVAL); ++ } else { /* end */ ++ sc->args = reverse_in_place(sc, sc->NIL, sc->args); ++ sc->code = car(sc->args); ++ sc->args = cdr(sc->args); ++ s_goto(sc,OP_APPLY); ++ } ++ ++#if USE_TRACING ++ case OP_TRACING: { ++ int tr=sc->tracing; ++ sc->tracing=ivalue(car(sc->args)); ++ s_return(sc,mk_integer(sc,tr)); ++ } ++#endif ++ ++ case OP_APPLY: /* apply 'code' to 'args' */ ++#if USE_TRACING ++ if(sc->tracing) { ++ s_save(sc,OP_REAL_APPLY,sc->args,sc->code); ++ sc->print_flag = 1; ++ /* sc->args=cons(sc,sc->code,sc->args);*/ ++ putstr(sc,"\nApply to: "); ++ s_goto(sc,OP_P0LIST); ++ } ++ /* fall through */ ++ case OP_REAL_APPLY: ++#endif ++ if (is_proc(sc->code)) { ++ s_goto(sc,procnum(sc->code)); /* PROCEDURE */ ++ } else if (is_foreign(sc->code)) ++ { ++ /* Keep nested calls from GC'ing the arglist */ ++ push_recent_alloc(sc,sc->args,sc->NIL); ++ x=sc->code->_object._ff(sc,sc->args); ++ s_return(sc,x); ++ } else if (is_closure(sc->code) || is_macro(sc->code) ++ || is_promise(sc->code)) { /* CLOSURE */ ++ /* Should not accept promise */ ++ /* make environment */ ++ new_frame_in_env(sc, closure_env(sc->code)); ++ for (x = car(closure_code(sc->code)), y = sc->args; ++ is_pair(x); x = cdr(x), y = cdr(y)) { ++ if (y == sc->NIL) { ++ Error_0(sc,"not enough arguments"); ++ } else { ++ new_slot_in_env(sc, car(x), car(y)); ++ } ++ } ++ if (x == sc->NIL) { ++ /*-- ++ * if (y != sc->NIL) { ++ * Error_0(sc,"too many arguments"); ++ * } ++ */ ++ } else if (is_symbol(x)) ++ new_slot_in_env(sc, x, y); ++ else { ++ Error_1(sc,"syntax error in closure: not a symbol:", x); ++ } ++ sc->code = cdr(closure_code(sc->code)); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_BEGIN); ++ } else if (is_continuation(sc->code)) { /* CONTINUATION */ ++ sc->dump = cont_dump(sc->code); ++ s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); ++ } else { ++ Error_0(sc,"illegal function"); ++ } ++ ++ case OP_DOMACRO: /* do macro */ ++ sc->code = sc->value; ++ s_goto(sc,OP_EVAL); ++ ++#if 1 ++ case OP_LAMBDA: /* lambda */ ++ /* If the hook is defined, apply it to sc->code, otherwise ++ set sc->value fall thru */ ++ { ++ pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1); ++ if(f==sc->NIL) { ++ sc->value = sc->code; ++ /* Fallthru */ ++ } else { ++ s_save(sc,OP_LAMBDA1,sc->args,sc->code); ++ sc->args=cons(sc,sc->code,sc->NIL); ++ sc->code=slot_value_in_env(f); ++ s_goto(sc,OP_APPLY); ++ } ++ } ++ ++ case OP_LAMBDA1: ++ s_return(sc,mk_closure(sc, sc->value, sc->envir)); ++ ++#else ++ case OP_LAMBDA: /* lambda */ ++ s_return(sc,mk_closure(sc, sc->code, sc->envir)); ++ ++#endif ++ ++ case OP_MKCLOSURE: /* make-closure */ ++ x=car(sc->args); ++ if(car(x)==sc->LAMBDA) { ++ x=cdr(x); ++ } ++ if(cdr(sc->args)==sc->NIL) { ++ y=sc->envir; ++ } else { ++ y=cadr(sc->args); ++ } ++ s_return(sc,mk_closure(sc, x, y)); ++ ++ case OP_QUOTE: /* quote */ ++ s_return(sc,car(sc->code)); ++ ++ case OP_DEF0: /* define */ ++ if(is_immutable(car(sc->code))) ++ Error_1(sc,"define: unable to alter immutable", car(sc->code)); ++ ++ if (is_pair(car(sc->code))) { ++ x = caar(sc->code); ++ sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); ++ } else { ++ x = car(sc->code); ++ sc->code = cadr(sc->code); ++ } ++ if (!is_symbol(x)) { ++ Error_0(sc,"variable is not a symbol"); ++ } ++ s_save(sc,OP_DEF1, sc->NIL, x); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_DEF1: /* define */ ++ x=find_slot_in_env(sc,sc->envir,sc->code,0); ++ if (x != sc->NIL) { ++ set_slot_in_env(sc, x, sc->value); ++ } else { ++ new_slot_in_env(sc, sc->code, sc->value); ++ } ++ s_return(sc,sc->code); ++ ++ ++ case OP_DEFP: /* defined? */ ++ x=sc->envir; ++ if(cdr(sc->args)!=sc->NIL) { ++ x=cadr(sc->args); ++ } ++ s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); ++ ++ case OP_SET0: /* set! */ ++ if(is_immutable(car(sc->code))) ++ Error_1(sc,"set!: unable to alter immutable variable",car(sc->code)); ++ s_save(sc,OP_SET1, sc->NIL, car(sc->code)); ++ sc->code = cadr(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_SET1: /* set! */ ++ y=find_slot_in_env(sc,sc->envir,sc->code,1); ++ if (y != sc->NIL) { ++ set_slot_in_env(sc, y, sc->value); ++ s_return(sc,sc->value); ++ } else { ++ Error_1(sc,"set!: unbound variable:", sc->code); ++ } ++ ++ ++ case OP_BEGIN: /* begin */ ++ if (!is_pair(sc->code)) { ++ s_return(sc,sc->code); ++ } ++ if (cdr(sc->code) != sc->NIL) { ++ s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); ++ } ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_IF0: /* if */ ++ s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_IF1: /* if */ ++ if (is_true(sc->value)) ++ sc->code = car(sc->code); ++ else ++ sc->code = cadr(sc->code); /* (if #f 1) ==> () because ++ * car(sc->NIL) = sc->NIL */ ++ s_goto(sc,OP_EVAL); ++ ++ case OP_LET0: /* let */ ++ sc->args = sc->NIL; ++ sc->value = sc->code; ++ sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); ++ s_goto(sc,OP_LET1); ++ ++ case OP_LET1: /* let (calculate parameters) */ ++ sc->args = cons(sc, sc->value, sc->args); ++ if (is_pair(sc->code)) { /* continue */ ++ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { ++ Error_1(sc, "Bad syntax of binding spec in let :", ++ car(sc->code)); ++ } ++ s_save(sc,OP_LET1, sc->args, cdr(sc->code)); ++ sc->code = cadar(sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_EVAL); ++ } else { /* end */ ++ sc->args = reverse_in_place(sc, sc->NIL, sc->args); ++ sc->code = car(sc->args); ++ sc->args = cdr(sc->args); ++ s_goto(sc,OP_LET2); ++ } ++ ++ case OP_LET2: /* let */ ++ new_frame_in_env(sc, sc->envir); ++ for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; ++ y != sc->NIL; x = cdr(x), y = cdr(y)) { ++ new_slot_in_env(sc, caar(x), car(y)); ++ } ++ if (is_symbol(car(sc->code))) { /* named let */ ++ for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { ++ if (!is_pair(x)) ++ Error_1(sc, "Bad syntax of binding in let :", x); ++ if (!is_list(sc, car(x))) ++ Error_1(sc, "Bad syntax of binding in let :", car(x)); ++ sc->args = cons(sc, caar(x), sc->args); ++ } ++ x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); ++ new_slot_in_env(sc, car(sc->code), x); ++ sc->code = cddr(sc->code); ++ sc->args = sc->NIL; ++ } else { ++ sc->code = cdr(sc->code); ++ sc->args = sc->NIL; ++ } ++ s_goto(sc,OP_BEGIN); ++ ++ case OP_LET0AST: /* let* */ ++ if (car(sc->code) == sc->NIL) { ++ new_frame_in_env(sc, sc->envir); ++ sc->code = cdr(sc->code); ++ s_goto(sc,OP_BEGIN); ++ } ++ if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) { ++ Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code)); ++ } ++ s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); ++ sc->code = cadaar(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_LET1AST: /* let* (make new frame) */ ++ new_frame_in_env(sc, sc->envir); ++ s_goto(sc,OP_LET2AST); ++ ++ case OP_LET2AST: /* let* (calculate parameters) */ ++ new_slot_in_env(sc, caar(sc->code), sc->value); ++ sc->code = cdr(sc->code); ++ if (is_pair(sc->code)) { /* continue */ ++ s_save(sc,OP_LET2AST, sc->args, sc->code); ++ sc->code = cadar(sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_EVAL); ++ } else { /* end */ ++ sc->code = sc->args; ++ sc->args = sc->NIL; ++ s_goto(sc,OP_BEGIN); ++ } ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ } ++ return sc->T; ++} ++ ++static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { ++ pointer x, y; ++ ++ switch (op) { ++ case OP_LET0REC: /* letrec */ ++ new_frame_in_env(sc, sc->envir); ++ sc->args = sc->NIL; ++ sc->value = sc->code; ++ sc->code = car(sc->code); ++ s_goto(sc,OP_LET1REC); ++ ++ case OP_LET1REC: /* letrec (calculate parameters) */ ++ sc->args = cons(sc, sc->value, sc->args); ++ if (is_pair(sc->code)) { /* continue */ ++ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { ++ Error_1(sc, "Bad syntax of binding spec in letrec :", ++ car(sc->code)); ++ } ++ s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); ++ sc->code = cadar(sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_EVAL); ++ } else { /* end */ ++ sc->args = reverse_in_place(sc, sc->NIL, sc->args); ++ sc->code = car(sc->args); ++ sc->args = cdr(sc->args); ++ s_goto(sc,OP_LET2REC); ++ } ++ ++ case OP_LET2REC: /* letrec */ ++ for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { ++ new_slot_in_env(sc, caar(x), car(y)); ++ } ++ sc->code = cdr(sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_BEGIN); ++ ++ case OP_COND0: /* cond */ ++ if (!is_pair(sc->code)) { ++ Error_0(sc,"syntax error in cond"); ++ } ++ s_save(sc,OP_COND1, sc->NIL, sc->code); ++ sc->code = caar(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_COND1: /* cond */ ++ if (is_true(sc->value)) { ++ if ((sc->code = cdar(sc->code)) == sc->NIL) { ++ s_return(sc,sc->value); ++ } ++ if(car(sc->code)==sc->FEED_TO) { ++ if(!is_pair(cdr(sc->code))) { ++ Error_0(sc,"syntax error in cond"); ++ } ++ x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); ++ sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); ++ s_goto(sc,OP_EVAL); ++ } ++ s_goto(sc,OP_BEGIN); ++ } else { ++ if ((sc->code = cdr(sc->code)) == sc->NIL) { ++ s_return(sc,sc->NIL); ++ } else { ++ s_save(sc,OP_COND1, sc->NIL, sc->code); ++ sc->code = caar(sc->code); ++ s_goto(sc,OP_EVAL); ++ } ++ } ++ ++ case OP_DELAY: /* delay */ ++ x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); ++ typeflag(x)=T_PROMISE; ++ s_return(sc,x); ++ ++ case OP_AND0: /* and */ ++ if (sc->code == sc->NIL) { ++ s_return(sc,sc->T); ++ } ++ s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_AND1: /* and */ ++ if (is_false(sc->value)) { ++ s_return(sc,sc->value); ++ } else if (sc->code == sc->NIL) { ++ s_return(sc,sc->value); ++ } else { ++ s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ } ++ ++ case OP_OR0: /* or */ ++ if (sc->code == sc->NIL) { ++ s_return(sc,sc->F); ++ } ++ s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_OR1: /* or */ ++ if (is_true(sc->value)) { ++ s_return(sc,sc->value); ++ } else if (sc->code == sc->NIL) { ++ s_return(sc,sc->value); ++ } else { ++ s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ } ++ ++ case OP_C0STREAM: /* cons-stream */ ++ s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_C1STREAM: /* cons-stream */ ++ sc->args = sc->value; /* save sc->value to register sc->args for gc */ ++ x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); ++ typeflag(x)=T_PROMISE; ++ s_return(sc,cons(sc, sc->args, x)); ++ ++ case OP_MACRO0: /* macro */ ++ if (is_pair(car(sc->code))) { ++ x = caar(sc->code); ++ sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); ++ } else { ++ x = car(sc->code); ++ sc->code = cadr(sc->code); ++ } ++ if (!is_symbol(x)) { ++ Error_0(sc,"variable is not a symbol"); ++ } ++ s_save(sc,OP_MACRO1, sc->NIL, x); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_MACRO1: /* macro */ ++ typeflag(sc->value) = T_MACRO; ++ x = find_slot_in_env(sc, sc->envir, sc->code, 0); ++ if (x != sc->NIL) { ++ set_slot_in_env(sc, x, sc->value); ++ } else { ++ new_slot_in_env(sc, sc->code, sc->value); ++ } ++ s_return(sc,sc->code); ++ ++ case OP_CASE0: /* case */ ++ s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_CASE1: /* case */ ++ for (x = sc->code; x != sc->NIL; x = cdr(x)) { ++ if (!is_pair(y = caar(x))) { ++ break; ++ } ++ for ( ; y != sc->NIL; y = cdr(y)) { ++ if (eqv(car(y), sc->value)) { ++ break; ++ } ++ } ++ if (y != sc->NIL) { ++ break; ++ } ++ } ++ if (x != sc->NIL) { ++ if (is_pair(caar(x))) { ++ sc->code = cdar(x); ++ s_goto(sc,OP_BEGIN); ++ } else {/* else */ ++ s_save(sc,OP_CASE2, sc->NIL, cdar(x)); ++ sc->code = caar(x); ++ s_goto(sc,OP_EVAL); ++ } ++ } else { ++ s_return(sc,sc->NIL); ++ } ++ ++ case OP_CASE2: /* case */ ++ if (is_true(sc->value)) { ++ s_goto(sc,OP_BEGIN); ++ } else { ++ s_return(sc,sc->NIL); ++ } ++ ++ case OP_PAPPLY: /* apply */ ++ sc->code = car(sc->args); ++ sc->args = list_star(sc,cdr(sc->args)); ++ /*sc->args = cadr(sc->args);*/ ++ s_goto(sc,OP_APPLY); ++ ++ case OP_PEVAL: /* eval */ ++ if(cdr(sc->args)!=sc->NIL) { ++ sc->envir=cadr(sc->args); ++ } ++ sc->code = car(sc->args); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_CONTINUATION: /* call-with-current-continuation */ ++ sc->code = car(sc->args); ++ sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); ++ s_goto(sc,OP_APPLY); ++ ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ } ++ return sc->T; ++} ++ ++static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { ++ pointer x; ++ num v; ++#if USE_MATH ++ double dd; ++#endif ++ ++ switch (op) { ++#if USE_MATH ++ case OP_INEX2EX: /* inexact->exact */ ++ x=car(sc->args); ++ if(num_is_integer(x)) { ++ s_return(sc,x); ++ } else if(modf(rvalue_unchecked(x),&dd)==0.0) { ++ s_return(sc,mk_integer(sc,ivalue(x))); ++ } else { ++ Error_1(sc,"inexact->exact: not integral:",x); ++ } ++ ++ case OP_EXP: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, exp(rvalue(x)))); ++ ++ case OP_LOG: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, log(rvalue(x)))); ++ ++ case OP_SIN: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, sin(rvalue(x)))); ++ ++ case OP_COS: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, cos(rvalue(x)))); ++ ++ case OP_TAN: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, tan(rvalue(x)))); ++ ++ case OP_ASIN: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, asin(rvalue(x)))); ++ ++ case OP_ACOS: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, acos(rvalue(x)))); ++ ++ case OP_ATAN: ++ x=car(sc->args); ++ if(cdr(sc->args)==sc->NIL) { ++ s_return(sc, mk_real(sc, atan(rvalue(x)))); ++ } else { ++ pointer y=cadr(sc->args); ++ s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); ++ } ++ ++ case OP_SQRT: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, sqrt(rvalue(x)))); ++ ++ case OP_EXPT: { ++ double result; ++ int real_result=1; ++ pointer y=cadr(sc->args); ++ x=car(sc->args); ++ if (num_is_integer(x) && num_is_integer(y)) ++ real_result=0; ++ /* This 'if' is an R5RS compatibility fix. */ ++ /* NOTE: Remove this 'if' fix for R6RS. */ ++ if (rvalue(x) == 0 && rvalue(y) < 0) { ++ result = 0.0; ++ } else { ++ result = pow(rvalue(x),rvalue(y)); ++ } ++ /* Before returning integer result make sure we can. */ ++ /* If the test fails, result is too big for integer. */ ++ if (!real_result) ++ { ++ long result_as_long = (long)result; ++ if (result != (double)result_as_long) ++ real_result = 1; ++ } ++ if (real_result) { ++ s_return(sc, mk_real(sc, result)); ++ } else { ++ s_return(sc, mk_integer(sc, result)); ++ } ++ } ++ ++ case OP_FLOOR: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, floor(rvalue(x)))); ++ ++ case OP_CEILING: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, ceil(rvalue(x)))); ++ ++ case OP_TRUNCATE : { ++ double rvalue_of_x ; ++ x=car(sc->args); ++ rvalue_of_x = rvalue(x) ; ++ if (rvalue_of_x > 0) { ++ s_return(sc, mk_real(sc, floor(rvalue_of_x))); ++ } else { ++ s_return(sc, mk_real(sc, ceil(rvalue_of_x))); ++ } ++ } ++ ++ case OP_ROUND: ++ x=car(sc->args); ++ if (num_is_integer(x)) ++ s_return(sc, x); ++ s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); ++#endif ++ ++ case OP_ADD: /* + */ ++ v=num_zero; ++ for (x = sc->args; x != sc->NIL; x = cdr(x)) { ++ v=num_add(v,nvalue(car(x))); ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_MUL: /* * */ ++ v=num_one; ++ for (x = sc->args; x != sc->NIL; x = cdr(x)) { ++ v=num_mul(v,nvalue(car(x))); ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_SUB: /* - */ ++ if(cdr(sc->args)==sc->NIL) { ++ x=sc->args; ++ v=num_zero; ++ } else { ++ x = cdr(sc->args); ++ v = nvalue(car(sc->args)); ++ } ++ for (; x != sc->NIL; x = cdr(x)) { ++ v=num_sub(v,nvalue(car(x))); ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_DIV: /* / */ ++ if(cdr(sc->args)==sc->NIL) { ++ x=sc->args; ++ v=num_one; ++ } else { ++ x = cdr(sc->args); ++ v = nvalue(car(sc->args)); ++ } ++ for (; x != sc->NIL; x = cdr(x)) { ++ if (!is_zero_double(rvalue(car(x)))) ++ v=num_div(v,nvalue(car(x))); ++ else { ++ Error_0(sc,"/: division by zero"); ++ } ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_INTDIV: /* quotient */ ++ if(cdr(sc->args)==sc->NIL) { ++ x=sc->args; ++ v=num_one; ++ } else { ++ x = cdr(sc->args); ++ v = nvalue(car(sc->args)); ++ } ++ for (; x != sc->NIL; x = cdr(x)) { ++ if (ivalue(car(x)) != 0) ++ v=num_intdiv(v,nvalue(car(x))); ++ else { ++ Error_0(sc,"quotient: division by zero"); ++ } ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_REM: /* remainder */ ++ v = nvalue(car(sc->args)); ++ if (ivalue(cadr(sc->args)) != 0) ++ v=num_rem(v,nvalue(cadr(sc->args))); ++ else { ++ Error_0(sc,"remainder: division by zero"); ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_MOD: /* modulo */ ++ v = nvalue(car(sc->args)); ++ if (ivalue(cadr(sc->args)) != 0) ++ v=num_mod(v,nvalue(cadr(sc->args))); ++ else { ++ Error_0(sc,"modulo: division by zero"); ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_CAR: /* car */ ++ s_return(sc,caar(sc->args)); ++ ++ case OP_CDR: /* cdr */ ++ s_return(sc,cdar(sc->args)); ++ ++ case OP_CONS: /* cons */ ++ cdr(sc->args) = cadr(sc->args); ++ s_return(sc,sc->args); ++ ++ case OP_SETCAR: /* set-car! */ ++ if(!is_immutable(car(sc->args))) { ++ caar(sc->args) = cadr(sc->args); ++ s_return(sc,car(sc->args)); ++ } else { ++ Error_0(sc,"set-car!: unable to alter immutable pair"); ++ } ++ ++ case OP_SETCDR: /* set-cdr! */ ++ if(!is_immutable(car(sc->args))) { ++ cdar(sc->args) = cadr(sc->args); ++ s_return(sc,car(sc->args)); ++ } else { ++ Error_0(sc,"set-cdr!: unable to alter immutable pair"); ++ } ++ ++ case OP_CHAR2INT: { /* char->integer */ ++ char c; ++ c=(char)ivalue(car(sc->args)); ++ s_return(sc,mk_integer(sc,(unsigned char)c)); ++ } ++ ++ case OP_INT2CHAR: { /* integer->char */ ++ unsigned char c; ++ c=(unsigned char)ivalue(car(sc->args)); ++ s_return(sc,mk_character(sc,(char)c)); ++ } ++ ++ case OP_CHARUPCASE: { ++ unsigned char c; ++ c=(unsigned char)ivalue(car(sc->args)); ++ c=toupper(c); ++ s_return(sc,mk_character(sc,(char)c)); ++ } ++ ++ case OP_CHARDNCASE: { ++ unsigned char c; ++ c=(unsigned char)ivalue(car(sc->args)); ++ c=tolower(c); ++ s_return(sc,mk_character(sc,(char)c)); ++ } ++ ++ case OP_STR2SYM: /* string->symbol */ ++ s_return(sc,mk_symbol(sc,strvalue(car(sc->args)))); ++ ++ case OP_STR2ATOM: /* string->atom */ { ++ char *s=strvalue(car(sc->args)); ++ long pf = 0; ++ if(cdr(sc->args)!=sc->NIL) { ++ /* we know cadr(sc->args) is a natural number */ ++ /* see if it is 2, 8, 10, or 16, or error */ ++ pf = ivalue_unchecked(cadr(sc->args)); ++ if(pf == 16 || pf == 10 || pf == 8 || pf == 2) { ++ /* base is OK */ ++ } ++ else { ++ pf = -1; ++ } ++ } ++ if (pf < 0) { ++ Error_1(sc, "string->atom: bad base:", cadr(sc->args)); ++ } else if(*s=='#') /* no use of base! */ { ++ s_return(sc, mk_sharp_const(sc, s+1)); ++ } else { ++ if (pf == 0 || pf == 10) { ++ s_return(sc, mk_atom(sc, s)); ++ } ++ else { ++ char *ep; ++ long iv = strtol(s,&ep,(int )pf); ++ if (*ep == 0) { ++ s_return(sc, mk_integer(sc, iv)); ++ } ++ else { ++ s_return(sc, sc->F); ++ } ++ } ++ } ++ } ++ ++ case OP_SYM2STR: /* symbol->string */ ++ x=mk_string(sc,symname(car(sc->args))); ++ setimmutable(x); ++ s_return(sc,x); ++ ++ case OP_ATOM2STR: /* atom->string */ { ++ long pf = 0; ++ x=car(sc->args); ++ if(cdr(sc->args)!=sc->NIL) { ++ /* we know cadr(sc->args) is a natural number */ ++ /* see if it is 2, 8, 10, or 16, or error */ ++ pf = ivalue_unchecked(cadr(sc->args)); ++ if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) { ++ /* base is OK */ ++ } ++ else { ++ pf = -1; ++ } ++ } ++ if (pf < 0) { ++ Error_1(sc, "atom->string: bad base:", cadr(sc->args)); ++ } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { ++ char *p; ++ int len; ++ atom2str(sc,x,(int )pf,&p,&len); ++ s_return(sc,mk_counted_string(sc,p,len)); ++ } else { ++ Error_1(sc, "atom->string: not an atom:", x); ++ } ++ } ++ ++ case OP_MKSTRING: { /* make-string */ ++ int fill=' '; ++ int len; ++ ++ len=ivalue(car(sc->args)); ++ ++ if(cdr(sc->args)!=sc->NIL) { ++ fill=charvalue(cadr(sc->args)); ++ } ++ s_return(sc,mk_empty_string(sc,len,(char)fill)); ++ } ++ ++ case OP_STRLEN: /* string-length */ ++ s_return(sc,mk_integer(sc,strlength(car(sc->args)))); ++ ++ case OP_STRREF: { /* string-ref */ ++ char *str; ++ int index; ++ ++ str=strvalue(car(sc->args)); ++ ++ index=ivalue(cadr(sc->args)); ++ ++ if(index>=strlength(car(sc->args))) { ++ Error_1(sc,"string-ref: out of bounds:",cadr(sc->args)); ++ } ++ ++ s_return(sc,mk_character(sc,((unsigned char*)str)[index])); ++ } ++ ++ case OP_STRSET: { /* string-set! */ ++ char *str; ++ int index; ++ int c; ++ ++ if(is_immutable(car(sc->args))) { ++ Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args)); ++ } ++ str=strvalue(car(sc->args)); ++ ++ index=ivalue(cadr(sc->args)); ++ if(index>=strlength(car(sc->args))) { ++ Error_1(sc,"string-set!: out of bounds:",cadr(sc->args)); ++ } ++ ++ c=charvalue(caddr(sc->args)); ++ ++ str[index]=(char)c; ++ s_return(sc,car(sc->args)); ++ } ++ ++ case OP_STRAPPEND: { /* string-append */ ++ /* in 1.29 string-append was in Scheme in init.scm but was too slow */ ++ int len = 0; ++ pointer newstr; ++ char *pos; ++ ++ /* compute needed length for new string */ ++ for (x = sc->args; x != sc->NIL; x = cdr(x)) { ++ len += strlength(car(x)); ++ } ++ newstr = mk_empty_string(sc, len, ' '); ++ /* store the contents of the argument strings into the new string */ ++ for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; ++ pos += strlength(car(x)), x = cdr(x)) { ++ memcpy(pos, strvalue(car(x)), strlength(car(x))); ++ } ++ s_return(sc, newstr); ++ } ++ ++ case OP_SUBSTR: { /* substring */ ++ char *str; ++ int index0; ++ int index1; ++ int len; ++ ++ str=strvalue(car(sc->args)); ++ ++ index0=ivalue(cadr(sc->args)); ++ ++ if(index0>strlength(car(sc->args))) { ++ Error_1(sc,"substring: start out of bounds:",cadr(sc->args)); ++ } ++ ++ if(cddr(sc->args)!=sc->NIL) { ++ index1=ivalue(caddr(sc->args)); ++ if(index1>strlength(car(sc->args)) || index1<index0) { ++ Error_1(sc,"substring: end out of bounds:",caddr(sc->args)); ++ } ++ } else { ++ index1=strlength(car(sc->args)); ++ } ++ ++ len=index1-index0; ++ x=mk_empty_string(sc,len,' '); ++ memcpy(strvalue(x),str+index0,len); ++ strvalue(x)[len]=0; ++ ++ s_return(sc,x); ++ } ++ ++ case OP_VECTOR: { /* vector */ ++ int i; ++ pointer vec; ++ int len=list_length(sc,sc->args); ++ if(len<0) { ++ Error_1(sc,"vector: not a proper list:",sc->args); ++ } ++ vec=mk_vector(sc,len); ++ if(sc->no_memory) { s_return(sc, sc->sink); } ++ for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) { ++ set_vector_elem(vec,i,car(x)); ++ } ++ s_return(sc,vec); ++ } ++ ++ case OP_MKVECTOR: { /* make-vector */ ++ pointer fill=sc->NIL; ++ int len; ++ pointer vec; ++ ++ len=ivalue(car(sc->args)); ++ ++ if(cdr(sc->args)!=sc->NIL) { ++ fill=cadr(sc->args); ++ } ++ vec=mk_vector(sc,len); ++ if(sc->no_memory) { s_return(sc, sc->sink); } ++ if(fill!=sc->NIL) { ++ fill_vector(vec,fill); ++ } ++ s_return(sc,vec); ++ } ++ ++ case OP_VECLEN: /* vector-length */ ++ s_return(sc,mk_integer(sc,ivalue(car(sc->args)))); ++ ++ case OP_VECREF: { /* vector-ref */ ++ int index; ++ ++ index=ivalue(cadr(sc->args)); ++ ++ if(index>=ivalue(car(sc->args))) { ++ Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args)); ++ } ++ ++ s_return(sc,vector_elem(car(sc->args),index)); ++ } ++ ++ case OP_VECSET: { /* vector-set! */ ++ int index; ++ ++ if(is_immutable(car(sc->args))) { ++ Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args)); ++ } ++ ++ index=ivalue(cadr(sc->args)); ++ if(index>=ivalue(car(sc->args))) { ++ Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args)); ++ } ++ ++ set_vector_elem(car(sc->args),index,caddr(sc->args)); ++ s_return(sc,car(sc->args)); ++ } ++ ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ } ++ return sc->T; ++} ++ ++static int is_list(scheme *sc, pointer a) ++{ return list_length(sc,a) >= 0; } ++ ++/* Result is: ++ proper list: length ++ circular list: -1 ++ not even a pair: -2 ++ dotted list: -2 minus length before dot ++*/ ++int list_length(scheme *sc, pointer a) { ++ int i=0; ++ pointer slow, fast; ++ ++ slow = fast = a; ++ while (1) ++ { ++ if (fast == sc->NIL) ++ return i; ++ if (!is_pair(fast)) ++ return -2 - i; ++ fast = cdr(fast); ++ ++i; ++ if (fast == sc->NIL) ++ return i; ++ if (!is_pair(fast)) ++ return -2 - i; ++ ++i; ++ fast = cdr(fast); ++ ++ /* Safe because we would have already returned if `fast' ++ encountered a non-pair. */ ++ slow = cdr(slow); ++ if (fast == slow) ++ { ++ /* the fast pointer has looped back around and caught up ++ with the slow pointer, hence the structure is circular, ++ not of finite length, and therefore not a list */ ++ return -1; ++ } ++ } ++} ++ ++static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { ++ pointer x; ++ num v; ++ int (*comp_func)(num,num)=0; ++ ++ switch (op) { ++ case OP_NOT: /* not */ ++ s_retbool(is_false(car(sc->args))); ++ case OP_BOOLP: /* boolean? */ ++ s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); ++ case OP_EOFOBJP: /* boolean? */ ++ s_retbool(car(sc->args) == sc->EOF_OBJ); ++ case OP_NULLP: /* null? */ ++ s_retbool(car(sc->args) == sc->NIL); ++ case OP_NUMEQ: /* = */ ++ case OP_LESS: /* < */ ++ case OP_GRE: /* > */ ++ case OP_LEQ: /* <= */ ++ case OP_GEQ: /* >= */ ++ switch(op) { ++ case OP_NUMEQ: comp_func=num_eq; break; ++ case OP_LESS: comp_func=num_lt; break; ++ case OP_GRE: comp_func=num_gt; break; ++ case OP_LEQ: comp_func=num_le; break; ++ case OP_GEQ: comp_func=num_ge; break; ++ } ++ x=sc->args; ++ v=nvalue(car(x)); ++ x=cdr(x); ++ ++ for (; x != sc->NIL; x = cdr(x)) { ++ if(!comp_func(v,nvalue(car(x)))) { ++ s_retbool(0); ++ } ++ v=nvalue(car(x)); ++ } ++ s_retbool(1); ++ case OP_SYMBOLP: /* symbol? */ ++ s_retbool(is_symbol(car(sc->args))); ++ case OP_NUMBERP: /* number? */ ++ s_retbool(is_number(car(sc->args))); ++ case OP_STRINGP: /* string? */ ++ s_retbool(is_string(car(sc->args))); ++ case OP_INTEGERP: /* integer? */ ++ s_retbool(is_integer(car(sc->args))); ++ case OP_REALP: /* real? */ ++ s_retbool(is_number(car(sc->args))); /* All numbers are real */ ++ case OP_CHARP: /* char? */ ++ s_retbool(is_character(car(sc->args))); ++#if USE_CHAR_CLASSIFIERS ++ case OP_CHARAP: /* char-alphabetic? */ ++ s_retbool(Cisalpha(ivalue(car(sc->args)))); ++ case OP_CHARNP: /* char-numeric? */ ++ s_retbool(Cisdigit(ivalue(car(sc->args)))); ++ case OP_CHARWP: /* char-whitespace? */ ++ s_retbool(Cisspace(ivalue(car(sc->args)))); ++ case OP_CHARUP: /* char-upper-case? */ ++ s_retbool(Cisupper(ivalue(car(sc->args)))); ++ case OP_CHARLP: /* char-lower-case? */ ++ s_retbool(Cislower(ivalue(car(sc->args)))); ++#endif ++ case OP_PORTP: /* port? */ ++ s_retbool(is_port(car(sc->args))); ++ case OP_INPORTP: /* input-port? */ ++ s_retbool(is_inport(car(sc->args))); ++ case OP_OUTPORTP: /* output-port? */ ++ s_retbool(is_outport(car(sc->args))); ++ case OP_PROCP: /* procedure? */ ++ /*-- ++ * continuation should be procedure by the example ++ * (call-with-current-continuation procedure?) ==> #t ++ * in R^3 report sec. 6.9 ++ */ ++ s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) ++ || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); ++ case OP_PAIRP: /* pair? */ ++ s_retbool(is_pair(car(sc->args))); ++ case OP_LISTP: /* list? */ ++ s_retbool(list_length(sc,car(sc->args)) >= 0); ++ ++ case OP_ENVP: /* environment? */ ++ s_retbool(is_environment(car(sc->args))); ++ case OP_VECTORP: /* vector? */ ++ s_retbool(is_vector(car(sc->args))); ++ case OP_EQ: /* eq? */ ++ s_retbool(car(sc->args) == cadr(sc->args)); ++ case OP_EQV: /* eqv? */ ++ s_retbool(eqv(car(sc->args), cadr(sc->args))); ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ } ++ return sc->T; ++} ++ ++static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { ++ pointer x, y; ++ ++ switch (op) { ++ case OP_FORCE: /* force */ ++ sc->code = car(sc->args); ++ if (is_promise(sc->code)) { ++ /* Should change type to closure here */ ++ s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_APPLY); ++ } else { ++ s_return(sc,sc->code); ++ } ++ ++ case OP_SAVE_FORCED: /* Save forced value replacing promise */ ++ memcpy(sc->code,sc->value,sizeof(struct cell)); ++ s_return(sc,sc->value); ++ ++ case OP_WRITE: /* write */ ++ case OP_DISPLAY: /* display */ ++ case OP_WRITE_CHAR: /* write-char */ ++ if(is_pair(cdr(sc->args))) { ++ if(cadr(sc->args)!=sc->outport) { ++ x=cons(sc,sc->outport,sc->NIL); ++ s_save(sc,OP_SET_OUTPORT, x, sc->NIL); ++ sc->outport=cadr(sc->args); ++ } ++ } ++ sc->args = car(sc->args); ++ if(op==OP_WRITE) { ++ sc->print_flag = 1; ++ } else { ++ sc->print_flag = 0; ++ } ++ s_goto(sc,OP_P0LIST); ++ ++ case OP_NEWLINE: /* newline */ ++ if(is_pair(sc->args)) { ++ if(car(sc->args)!=sc->outport) { ++ x=cons(sc,sc->outport,sc->NIL); ++ s_save(sc,OP_SET_OUTPORT, x, sc->NIL); ++ sc->outport=car(sc->args); ++ } ++ } ++ putstr(sc, "\n"); ++ s_return(sc,sc->T); ++ ++ case OP_ERR0: /* error */ ++ sc->retcode=-1; ++ if (!is_string(car(sc->args))) { ++ sc->args=cons(sc,mk_string(sc," -- "),sc->args); ++ setimmutable(car(sc->args)); ++ } ++ putstr(sc, "Error: "); ++ putstr(sc, strvalue(car(sc->args))); ++ sc->args = cdr(sc->args); ++ s_goto(sc,OP_ERR1); ++ ++ case OP_ERR1: /* error */ ++ putstr(sc, " "); ++ if (sc->args != sc->NIL) { ++ s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); ++ sc->args = car(sc->args); ++ sc->print_flag = 1; ++ s_goto(sc,OP_P0LIST); ++ } else { ++ putstr(sc, "\n"); ++ if(sc->interactive_repl) { ++ s_goto(sc,OP_T0LVL); ++ } else { ++ return sc->NIL; ++ } ++ } ++ ++ case OP_REVERSE: /* reverse */ ++ s_return(sc,reverse(sc, car(sc->args))); ++ ++ case OP_LIST_STAR: /* list* */ ++ s_return(sc,list_star(sc,sc->args)); ++ ++ case OP_APPEND: /* append */ ++ x = sc->NIL; ++ y = sc->args; ++ if (y == x) { ++ s_return(sc, x); ++ } ++ ++ /* cdr() in the while condition is not a typo. If car() */ ++ /* is used (append '() 'a) will return the wrong result.*/ ++ while (cdr(y) != sc->NIL) { ++ x = revappend(sc, x, car(y)); ++ y = cdr(y); ++ if (x == sc->F) { ++ Error_0(sc, "non-list argument to append"); ++ } ++ } ++ ++ s_return(sc, reverse_in_place(sc, car(y), x)); ++ ++#if USE_PLIST ++ case OP_PUT: /* put */ ++ if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { ++ Error_0(sc,"illegal use of put"); ++ } ++ for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { ++ if (caar(x) == y) { ++ break; ++ } ++ } ++ if (x != sc->NIL) ++ cdar(x) = caddr(sc->args); ++ else ++ symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)), ++ symprop(car(sc->args))); ++ s_return(sc,sc->T); ++ ++ case OP_GET: /* get */ ++ if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { ++ Error_0(sc,"illegal use of get"); ++ } ++ for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { ++ if (caar(x) == y) { ++ break; ++ } ++ } ++ if (x != sc->NIL) { ++ s_return(sc,cdar(x)); ++ } else { ++ s_return(sc,sc->NIL); ++ } ++#endif /* USE_PLIST */ ++ case OP_QUIT: /* quit */ ++ if(is_pair(sc->args)) { ++ sc->retcode=ivalue(car(sc->args)); ++ } ++ return (sc->NIL); ++ ++ case OP_GC: /* gc */ ++ gc(sc, sc->NIL, sc->NIL); ++ s_return(sc,sc->T); ++ ++ case OP_GCVERB: /* gc-verbose */ ++ { int was = sc->gc_verbose; ++ ++ sc->gc_verbose = (car(sc->args) != sc->F); ++ s_retbool(was); ++ } ++ ++ case OP_NEWSEGMENT: /* new-segment */ ++ if (!is_pair(sc->args) || !is_number(car(sc->args))) { ++ Error_0(sc,"new-segment: argument must be a number"); ++ } ++ alloc_cellseg(sc, (int) ivalue(car(sc->args))); ++ s_return(sc,sc->T); ++ ++ case OP_OBLIST: /* oblist */ ++ s_return(sc, oblist_all_symbols(sc)); ++ ++ case OP_CURR_INPORT: /* current-input-port */ ++ s_return(sc,sc->inport); ++ ++ case OP_CURR_OUTPORT: /* current-output-port */ ++ s_return(sc,sc->outport); ++ ++ case OP_OPEN_INFILE: /* open-input-file */ ++ case OP_OPEN_OUTFILE: /* open-output-file */ ++ case OP_OPEN_INOUTFILE: /* open-input-output-file */ { ++ int prop=0; ++ pointer p; ++ switch(op) { ++ case OP_OPEN_INFILE: prop=port_input; break; ++ case OP_OPEN_OUTFILE: prop=port_output; break; ++ case OP_OPEN_INOUTFILE: prop=port_input|port_output; break; ++ } ++ p=port_from_filename(sc,strvalue(car(sc->args)),prop); ++ if(p==sc->NIL) { ++ s_return(sc,sc->F); ++ } ++ s_return(sc,p); ++ } ++ ++#if USE_STRING_PORTS ++ case OP_OPEN_INSTRING: /* open-input-string */ ++ case OP_OPEN_INOUTSTRING: /* open-input-output-string */ { ++ int prop=0; ++ pointer p; ++ switch(op) { ++ case OP_OPEN_INSTRING: prop=port_input; break; ++ case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; ++ } ++ p=port_from_string(sc, strvalue(car(sc->args)), ++ strvalue(car(sc->args))+strlength(car(sc->args)), prop); ++ if(p==sc->NIL) { ++ s_return(sc,sc->F); ++ } ++ s_return(sc,p); ++ } ++ case OP_OPEN_OUTSTRING: /* open-output-string */ { ++ pointer p; ++ if(car(sc->args)==sc->NIL) { ++ p=port_from_scratch(sc); ++ if(p==sc->NIL) { ++ s_return(sc,sc->F); ++ } ++ } else { ++ p=port_from_string(sc, strvalue(car(sc->args)), ++ strvalue(car(sc->args))+strlength(car(sc->args)), ++ port_output); ++ if(p==sc->NIL) { ++ s_return(sc,sc->F); ++ } ++ } ++ s_return(sc,p); ++ } ++ case OP_GET_OUTSTRING: /* get-output-string */ { ++ port *p; ++ ++ if ((p=car(sc->args)->_object._port)->kind&port_string) { ++ off_t size; ++ char *str; ++ ++ size=p->rep.string.curr-p->rep.string.start+1; ++ str=sc->malloc(size); ++ if(str != NULL) { ++ pointer s; ++ ++ memcpy(str,p->rep.string.start,size-1); ++ str[size-1]='\0'; ++ s=mk_string(sc,str); ++ sc->free(str); ++ s_return(sc,s); ++ } ++ } ++ s_return(sc,sc->F); ++ } ++#endif ++ ++ case OP_CLOSE_INPORT: /* close-input-port */ ++ port_close(sc,car(sc->args),port_input); ++ s_return(sc,sc->T); ++ ++ case OP_CLOSE_OUTPORT: /* close-output-port */ ++ port_close(sc,car(sc->args),port_output); ++ s_return(sc,sc->T); ++ ++ case OP_INT_ENV: /* interaction-environment */ ++ s_return(sc,sc->global_env); ++ ++ case OP_CURR_ENV: /* current-environment */ ++ s_return(sc,sc->envir); ++ ++ } ++ return sc->T; ++} ++ ++static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { ++ pointer x; ++ ++ if(sc->nesting!=0) { ++ int n=sc->nesting; ++ sc->nesting=0; ++ sc->retcode=-1; ++ Error_1(sc,"unmatched parentheses:",mk_integer(sc,n)); ++ } ++ ++ switch (op) { ++ /* ========== reading part ========== */ ++ case OP_READ: ++ if(!is_pair(sc->args)) { ++ s_goto(sc,OP_READ_INTERNAL); ++ } ++ if(!is_inport(car(sc->args))) { ++ Error_1(sc,"read: not an input port:",car(sc->args)); ++ } ++ if(car(sc->args)==sc->inport) { ++ s_goto(sc,OP_READ_INTERNAL); ++ } ++ x=sc->inport; ++ sc->inport=car(sc->args); ++ x=cons(sc,x,sc->NIL); ++ s_save(sc,OP_SET_INPORT, x, sc->NIL); ++ s_goto(sc,OP_READ_INTERNAL); ++ ++ case OP_READ_CHAR: /* read-char */ ++ case OP_PEEK_CHAR: /* peek-char */ { ++ int c; ++ if(is_pair(sc->args)) { ++ if(car(sc->args)!=sc->inport) { ++ x=sc->inport; ++ x=cons(sc,x,sc->NIL); ++ s_save(sc,OP_SET_INPORT, x, sc->NIL); ++ sc->inport=car(sc->args); ++ } ++ } ++ c=inchar(sc); ++ if(c==EOF) { ++ s_return(sc,sc->EOF_OBJ); ++ } ++ if(sc->op==OP_PEEK_CHAR) { ++ backchar(sc,c); ++ } ++ s_return(sc,mk_character(sc,c)); ++ } ++ ++ case OP_CHAR_READY: /* char-ready? */ { ++ pointer p=sc->inport; ++ int res; ++ if(is_pair(sc->args)) { ++ p=car(sc->args); ++ } ++ res=p->_object._port->kind&port_string; ++ s_retbool(res); ++ } ++ ++ case OP_SET_INPORT: /* set-input-port */ ++ sc->inport=car(sc->args); ++ s_return(sc,sc->value); ++ ++ case OP_SET_OUTPORT: /* set-output-port */ ++ sc->outport=car(sc->args); ++ s_return(sc,sc->value); ++ ++ case OP_RDSEXPR: ++ switch (sc->tok) { ++ case TOK_EOF: ++ s_return(sc,sc->EOF_OBJ); ++ /* NOTREACHED */ ++/* ++ * Commented out because we now skip comments in the scanner ++ * ++ case TOK_COMMENT: { ++ int c; ++ while ((c=inchar(sc)) != '\n' && c!=EOF) ++ ; ++ sc->tok = token(sc); ++ s_goto(sc,OP_RDSEXPR); ++ } ++*/ ++ case TOK_VEC: ++ s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); ++ /* fall through */ ++ case TOK_LPAREN: ++ sc->tok = token(sc); ++ if (sc->tok == TOK_RPAREN) { ++ s_return(sc,sc->NIL); ++ } else if (sc->tok == TOK_DOT) { ++ Error_0(sc,"syntax error: illegal dot expression"); ++ } else { ++ sc->nesting_stack[sc->file_i]++; ++ s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); ++ s_goto(sc,OP_RDSEXPR); ++ } ++ case TOK_QUOTE: ++ s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); ++ sc->tok = token(sc); ++ s_goto(sc,OP_RDSEXPR); ++ case TOK_BQUOTE: ++ sc->tok = token(sc); ++ if(sc->tok==TOK_VEC) { ++ s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); ++ sc->tok=TOK_LPAREN; ++ s_goto(sc,OP_RDSEXPR); ++ } else { ++ s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); ++ } ++ s_goto(sc,OP_RDSEXPR); ++ case TOK_COMMA: ++ s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); ++ sc->tok = token(sc); ++ s_goto(sc,OP_RDSEXPR); ++ case TOK_ATMARK: ++ s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); ++ sc->tok = token(sc); ++ s_goto(sc,OP_RDSEXPR); ++ case TOK_ATOM: ++ s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS))); ++ case TOK_DQUOTE: ++ x=readstrexp(sc); ++ if(x==sc->F) { ++ Error_0(sc,"Error reading string"); ++ } ++ setimmutable(x); ++ s_return(sc,x); ++ case TOK_SHARP: { ++ pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1); ++ if(f==sc->NIL) { ++ Error_0(sc,"undefined sharp expression"); ++ } else { ++ sc->code=cons(sc,slot_value_in_env(f),sc->NIL); ++ s_goto(sc,OP_EVAL); ++ } ++ } ++ case TOK_SHARP_CONST: ++ if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) { ++ Error_0(sc,"undefined sharp expression"); ++ } else { ++ s_return(sc,x); ++ } ++ default: ++ Error_0(sc,"syntax error: illegal token"); ++ } ++ break; ++ ++ case OP_RDLIST: { ++ sc->args = cons(sc, sc->value, sc->args); ++ sc->tok = token(sc); ++/* We now skip comments in the scanner ++ while (sc->tok == TOK_COMMENT) { ++ int c; ++ while ((c=inchar(sc)) != '\n' && c!=EOF) ++ ; ++ sc->tok = token(sc); ++ } ++*/ ++ if (sc->tok == TOK_EOF) ++ { s_return(sc,sc->EOF_OBJ); } ++ else if (sc->tok == TOK_RPAREN) { ++ int c = inchar(sc); ++ if (c != '\n') ++ backchar(sc,c); ++#if SHOW_ERROR_LINE ++ else if (sc->load_stack[sc->file_i].kind & port_file) ++ sc->load_stack[sc->file_i].rep.stdio.curr_line++; ++#endif ++ sc->nesting_stack[sc->file_i]--; ++ s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); ++ } else if (sc->tok == TOK_DOT) { ++ s_save(sc,OP_RDDOT, sc->args, sc->NIL); ++ sc->tok = token(sc); ++ s_goto(sc,OP_RDSEXPR); ++ } else { ++ s_save(sc,OP_RDLIST, sc->args, sc->NIL);; ++ s_goto(sc,OP_RDSEXPR); ++ } ++ } ++ ++ case OP_RDDOT: ++ if (token(sc) != TOK_RPAREN) { ++ Error_0(sc,"syntax error: illegal dot expression"); ++ } else { ++ sc->nesting_stack[sc->file_i]--; ++ s_return(sc,reverse_in_place(sc, sc->value, sc->args)); ++ } ++ ++ case OP_RDQUOTE: ++ s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL))); ++ ++ case OP_RDQQUOTE: ++ s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL))); ++ ++ case OP_RDQQUOTEVEC: ++ s_return(sc,cons(sc, mk_symbol(sc,"apply"), ++ cons(sc, mk_symbol(sc,"vector"), ++ cons(sc,cons(sc, sc->QQUOTE, ++ cons(sc,sc->value,sc->NIL)), ++ sc->NIL)))); ++ ++ case OP_RDUNQUOTE: ++ s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL))); ++ ++ case OP_RDUQTSP: ++ s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL))); ++ ++ case OP_RDVEC: ++ /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); ++ s_goto(sc,OP_EVAL); Cannot be quoted*/ ++ /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); ++ s_return(sc,x); Cannot be part of pairs*/ ++ /*sc->code=mk_proc(sc,OP_VECTOR); ++ sc->args=sc->value; ++ s_goto(sc,OP_APPLY);*/ ++ sc->args=sc->value; ++ s_goto(sc,OP_VECTOR); ++ ++ /* ========== printing part ========== */ ++ case OP_P0LIST: ++ if(is_vector(sc->args)) { ++ putstr(sc,"#("); ++ sc->args=cons(sc,sc->args,mk_integer(sc,0)); ++ s_goto(sc,OP_PVECFROM); ++ } else if(is_environment(sc->args)) { ++ putstr(sc,"#<ENVIRONMENT>"); ++ s_return(sc,sc->T); ++ } else if (!is_pair(sc->args)) { ++ printatom(sc, sc->args, sc->print_flag); ++ s_return(sc,sc->T); ++ } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { ++ putstr(sc, "'"); ++ sc->args = cadr(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { ++ putstr(sc, "`"); ++ sc->args = cadr(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { ++ putstr(sc, ","); ++ sc->args = cadr(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { ++ putstr(sc, ",@"); ++ sc->args = cadr(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } else { ++ putstr(sc, "("); ++ s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); ++ sc->args = car(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } ++ ++ case OP_P1LIST: ++ if (is_pair(sc->args)) { ++ s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); ++ putstr(sc, " "); ++ sc->args = car(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } else if(is_vector(sc->args)) { ++ s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); ++ putstr(sc, " . "); ++ s_goto(sc,OP_P0LIST); ++ } else { ++ if (sc->args != sc->NIL) { ++ putstr(sc, " . "); ++ printatom(sc, sc->args, sc->print_flag); ++ } ++ putstr(sc, ")"); ++ s_return(sc,sc->T); ++ } ++ case OP_PVECFROM: { ++ int i=ivalue_unchecked(cdr(sc->args)); ++ pointer vec=car(sc->args); ++ int len=ivalue_unchecked(vec); ++ if(i==len) { ++ putstr(sc,")"); ++ s_return(sc,sc->T); ++ } else { ++ pointer elem=vector_elem(vec,i); ++ ivalue_unchecked(cdr(sc->args))=i+1; ++ s_save(sc,OP_PVECFROM, sc->args, sc->NIL); ++ sc->args=elem; ++ if (i > 0) ++ putstr(sc," "); ++ s_goto(sc,OP_P0LIST); ++ } ++ } ++ ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ ++ } ++ return sc->T; ++} ++ ++static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { ++ pointer x, y; ++ long v; ++ ++ switch (op) { ++ case OP_LIST_LENGTH: /* length */ /* a.k */ ++ v=list_length(sc,car(sc->args)); ++ if(v<0) { ++ Error_1(sc,"length: not a list:",car(sc->args)); ++ } ++ s_return(sc,mk_integer(sc, v)); ++ ++ case OP_ASSQ: /* assq */ /* a.k */ ++ x = car(sc->args); ++ for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { ++ if (!is_pair(car(y))) { ++ Error_0(sc,"unable to handle non pair element"); ++ } ++ if (x == caar(y)) ++ break; ++ } ++ if (is_pair(y)) { ++ s_return(sc,car(y)); ++ } else { ++ s_return(sc,sc->F); ++ } ++ ++ ++ case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */ ++ sc->args = car(sc->args); ++ if (sc->args == sc->NIL) { ++ s_return(sc,sc->F); ++ } else if (is_closure(sc->args)) { ++ s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); ++ } else if (is_macro(sc->args)) { ++ s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); ++ } else { ++ s_return(sc,sc->F); ++ } ++ case OP_CLOSUREP: /* closure? */ ++ /* ++ * Note, macro object is also a closure. ++ * Therefore, (closure? <#MACRO>) ==> #t ++ */ ++ s_retbool(is_closure(car(sc->args))); ++ case OP_MACROP: /* macro? */ ++ s_retbool(is_macro(car(sc->args))); ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ } ++ return sc->T; /* NOTREACHED */ ++} ++ ++typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes); ++ ++typedef int (*test_predicate)(pointer); ++static int is_any(pointer p) { return 1;} ++ ++static int is_nonneg(pointer p) { ++ return ivalue(p)>=0 && is_integer(p); ++} ++ ++/* Correspond carefully with following defines! */ ++static struct { ++ test_predicate fct; ++ const char *kind; ++} tests[]={ ++ {0,0}, /* unused */ ++ {is_any, 0}, ++ {is_string, "string"}, ++ {is_symbol, "symbol"}, ++ {is_port, "port"}, ++ {is_inport,"input port"}, ++ {is_outport,"output port"}, ++ {is_environment, "environment"}, ++ {is_pair, "pair"}, ++ {0, "pair or '()"}, ++ {is_character, "character"}, ++ {is_vector, "vector"}, ++ {is_number, "number"}, ++ {is_integer, "integer"}, ++ {is_nonneg, "non-negative integer"} ++}; ++ ++#define TST_NONE 0 ++#define TST_ANY "\001" ++#define TST_STRING "\002" ++#define TST_SYMBOL "\003" ++#define TST_PORT "\004" ++#define TST_INPORT "\005" ++#define TST_OUTPORT "\006" ++#define TST_ENVIRONMENT "\007" ++#define TST_PAIR "\010" ++#define TST_LIST "\011" ++#define TST_CHAR "\012" ++#define TST_VECTOR "\013" ++#define TST_NUMBER "\014" ++#define TST_INTEGER "\015" ++#define TST_NATURAL "\016" ++ ++typedef struct { ++ dispatch_func func; ++ char *name; ++ int min_arity; ++ int max_arity; ++ char *arg_tests_encoding; ++} op_code_info; ++ ++#define INF_ARG 0xffff ++ ++static op_code_info dispatch_table[]= { ++#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, ++#include "opdefines.h" ++ { 0 } ++}; ++ ++static const char *procname(pointer x) { ++ int n=procnum(x); ++ const char *name=dispatch_table[n].name; ++ if(name==0) { ++ name="ILLEGAL!"; ++ } ++ return name; ++} ++ ++/* kernel of this interpreter */ ++static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { ++ sc->op = op; ++ for (;;) { ++ op_code_info *pcd=dispatch_table+sc->op; ++ if (pcd->name!=0) { /* if built-in function, check arguments */ ++ char msg[STRBUFFSIZE]; ++ int ok=1; ++ int n=list_length(sc,sc->args); ++ ++ /* Check number of arguments */ ++ if(n<pcd->min_arity) { ++ ok=0; ++ snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", ++ pcd->name, ++ pcd->min_arity==pcd->max_arity?"":" at least", ++ pcd->min_arity); ++ } ++ if(ok && n>pcd->max_arity) { ++ ok=0; ++ snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", ++ pcd->name, ++ pcd->min_arity==pcd->max_arity?"":" at most", ++ pcd->max_arity); ++ } ++ if(ok) { ++ if(pcd->arg_tests_encoding!=0) { ++ int i=0; ++ int j; ++ const char *t=pcd->arg_tests_encoding; ++ pointer arglist=sc->args; ++ do { ++ pointer arg=car(arglist); ++ j=(int)t[0]; ++ if(j==TST_LIST[0]) { ++ if(arg!=sc->NIL && !is_pair(arg)) break; ++ } else { ++ if(!tests[j].fct(arg)) break; ++ } ++ ++ if(t[1]!=0) {/* last test is replicated as necessary */ ++ t++; ++ } ++ arglist=cdr(arglist); ++ i++; ++ } while(i<n); ++ if(i<n) { ++ ok=0; ++ snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s", ++ pcd->name, ++ i+1, ++ tests[j].kind); ++ } ++ } ++ } ++ if(!ok) { ++ if(_Error_1(sc,msg,0)==sc->NIL) { ++ return; ++ } ++ pcd=dispatch_table+sc->op; ++ } ++ } ++ ok_to_freely_gc(sc); ++ if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) { ++ return; ++ } ++ if(sc->no_memory) { ++ fprintf(stderr,"No memory!\n"); ++ return; ++ } ++ } ++} ++ ++/* ========== Initialization of internal keywords ========== */ ++ ++static void assign_syntax(scheme *sc, char *name) { ++ pointer x; ++ ++ x = oblist_add_by_name(sc, name); ++ typeflag(x) |= T_SYNTAX; ++} ++ ++static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) { ++ pointer x, y; ++ ++ x = mk_symbol(sc, name); ++ y = mk_proc(sc,op); ++ new_slot_in_env(sc, x, y); ++} ++ ++static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { ++ pointer y; ++ ++ y = get_cell(sc, sc->NIL, sc->NIL); ++ typeflag(y) = (T_PROC | T_ATOM); ++ ivalue_unchecked(y) = (long) op; ++ set_num_integer(y); ++ return y; ++} ++ ++/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ ++static int syntaxnum(pointer p) { ++ const char *s=strvalue(car(p)); ++ switch(strlength(car(p))) { ++ case 2: ++ if(s[0]=='i') return OP_IF0; /* if */ ++ else return OP_OR0; /* or */ ++ case 3: ++ if(s[0]=='a') return OP_AND0; /* and */ ++ else return OP_LET0; /* let */ ++ case 4: ++ switch(s[3]) { ++ case 'e': return OP_CASE0; /* case */ ++ case 'd': return OP_COND0; /* cond */ ++ case '*': return OP_LET0AST; /* let* */ ++ default: return OP_SET0; /* set! */ ++ } ++ case 5: ++ switch(s[2]) { ++ case 'g': return OP_BEGIN; /* begin */ ++ case 'l': return OP_DELAY; /* delay */ ++ case 'c': return OP_MACRO0; /* macro */ ++ default: return OP_QUOTE; /* quote */ ++ } ++ case 6: ++ switch(s[2]) { ++ case 'm': return OP_LAMBDA; /* lambda */ ++ case 'f': return OP_DEF0; /* define */ ++ default: return OP_LET0REC; /* letrec */ ++ } ++ default: ++ return OP_C0STREAM; /* cons-stream */ ++ } ++} ++ ++/* initialization of TinyScheme */ ++#if USE_INTERFACE ++INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { ++ return cons(sc,a,b); ++} ++INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { ++ return immutable_cons(sc,a,b); ++} ++ ++static struct scheme_interface vtbl ={ ++ scheme_define, ++ s_cons, ++ s_immutable_cons, ++ reserve_cells, ++ mk_integer, ++ mk_real, ++ mk_symbol, ++ gensym, ++ mk_string, ++ mk_counted_string, ++ mk_character, ++ mk_vector, ++ mk_foreign_func, ++ putstr, ++ putcharacter, ++ ++ is_string, ++ string_value, ++ is_number, ++ nvalue, ++ ivalue, ++ rvalue, ++ is_integer, ++ is_real, ++ is_character, ++ charvalue, ++ is_list, ++ is_vector, ++ list_length, ++ ivalue, ++ fill_vector, ++ vector_elem, ++ set_vector_elem, ++ is_port, ++ is_pair, ++ pair_car, ++ pair_cdr, ++ set_car, ++ set_cdr, ++ ++ is_symbol, ++ symname, ++ ++ is_syntax, ++ is_proc, ++ is_foreign, ++ syntaxname, ++ is_closure, ++ is_macro, ++ closure_code, ++ closure_env, ++ ++ is_continuation, ++ is_promise, ++ is_environment, ++ is_immutable, ++ setimmutable, ++ ++ scheme_load_file, ++ scheme_load_string ++}; ++#endif ++ ++scheme *scheme_init_new() { ++ scheme *sc=(scheme*)malloc(sizeof(scheme)); ++ if(!scheme_init(sc)) { ++ free(sc); ++ return 0; ++ } else { ++ return sc; ++ } ++} ++ ++scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) { ++ scheme *sc=(scheme*)malloc(sizeof(scheme)); ++ if(!scheme_init_custom_alloc(sc,malloc,free)) { ++ free(sc); ++ return 0; ++ } else { ++ return sc; ++ } ++} ++ ++ ++int scheme_init(scheme *sc) { ++ return scheme_init_custom_alloc(sc,malloc,free); ++} ++ ++int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { ++ int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); ++ pointer x; ++ ++ num_zero.is_fixnum=1; ++ num_zero.value.ivalue=0; ++ num_one.is_fixnum=1; ++ num_one.value.ivalue=1; ++ ++#if USE_INTERFACE ++ sc->vptr=&vtbl; ++#endif ++ sc->gensym_cnt=0; ++ sc->malloc=malloc; ++ sc->free=free; ++ sc->last_cell_seg = -1; ++ sc->sink = &sc->_sink; ++ sc->NIL = &sc->_NIL; ++ sc->T = &sc->_HASHT; ++ sc->F = &sc->_HASHF; ++ sc->EOF_OBJ=&sc->_EOF_OBJ; ++ sc->free_cell = &sc->_NIL; ++ sc->fcells = 0; ++ sc->no_memory=0; ++ sc->inport=sc->NIL; ++ sc->outport=sc->NIL; ++ sc->save_inport=sc->NIL; ++ sc->loadport=sc->NIL; ++ sc->nesting=0; ++ sc->interactive_repl=0; ++ ++ if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { ++ sc->no_memory=1; ++ return 0; ++ } ++ sc->gc_verbose = 0; ++ dump_stack_initialize(sc); ++ sc->code = sc->NIL; ++ sc->tracing=0; ++ ++ /* init sc->NIL */ ++ typeflag(sc->NIL) = (T_ATOM | MARK); ++ car(sc->NIL) = cdr(sc->NIL) = sc->NIL; ++ /* init T */ ++ typeflag(sc->T) = (T_ATOM | MARK); ++ car(sc->T) = cdr(sc->T) = sc->T; ++ /* init F */ ++ typeflag(sc->F) = (T_ATOM | MARK); ++ car(sc->F) = cdr(sc->F) = sc->F; ++ /* init sink */ ++ typeflag(sc->sink) = (T_PAIR | MARK); ++ car(sc->sink) = sc->NIL; ++ /* init c_nest */ ++ sc->c_nest = sc->NIL; ++ ++ sc->oblist = oblist_initial_value(sc); ++ /* init global_env */ ++ new_frame_in_env(sc, sc->NIL); ++ sc->global_env = sc->envir; ++ /* init else */ ++ x = mk_symbol(sc,"else"); ++ new_slot_in_env(sc, x, sc->T); ++ ++ assign_syntax(sc, "lambda"); ++ assign_syntax(sc, "quote"); ++ assign_syntax(sc, "define"); ++ assign_syntax(sc, "if"); ++ assign_syntax(sc, "begin"); ++ assign_syntax(sc, "set!"); ++ assign_syntax(sc, "let"); ++ assign_syntax(sc, "let*"); ++ assign_syntax(sc, "letrec"); ++ assign_syntax(sc, "cond"); ++ assign_syntax(sc, "delay"); ++ assign_syntax(sc, "and"); ++ assign_syntax(sc, "or"); ++ assign_syntax(sc, "cons-stream"); ++ assign_syntax(sc, "macro"); ++ assign_syntax(sc, "case"); ++ ++ for(i=0; i<n; i++) { ++ if(dispatch_table[i].name!=0) { ++ assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name); ++ } ++ } ++ ++ /* initialization of global pointers to special symbols */ ++ sc->LAMBDA = mk_symbol(sc, "lambda"); ++ sc->QUOTE = mk_symbol(sc, "quote"); ++ sc->QQUOTE = mk_symbol(sc, "quasiquote"); ++ sc->UNQUOTE = mk_symbol(sc, "unquote"); ++ sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing"); ++ sc->FEED_TO = mk_symbol(sc, "=>"); ++ sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); ++ sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); ++ sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); ++ sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*"); ++ ++ return !sc->no_memory; ++} ++ ++void scheme_set_input_port_file(scheme *sc, FILE *fin) { ++ sc->inport=port_from_file(sc,fin,port_input); ++} ++ ++void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) { ++ sc->inport=port_from_string(sc,start,past_the_end,port_input); ++} ++ ++void scheme_set_output_port_file(scheme *sc, FILE *fout) { ++ sc->outport=port_from_file(sc,fout,port_output); ++} ++ ++void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) { ++ sc->outport=port_from_string(sc,start,past_the_end,port_output); ++} ++ ++void scheme_set_external_data(scheme *sc, void *p) { ++ sc->ext_data=p; ++} ++ ++void scheme_deinit(scheme *sc) { ++ int i; ++ ++#if SHOW_ERROR_LINE ++ char *fname; ++#endif ++ ++ sc->oblist=sc->NIL; ++ sc->global_env=sc->NIL; ++ dump_stack_free(sc); ++ sc->envir=sc->NIL; ++ sc->code=sc->NIL; ++ sc->args=sc->NIL; ++ sc->value=sc->NIL; ++ if(is_port(sc->inport)) { ++ typeflag(sc->inport) = T_ATOM; ++ } ++ sc->inport=sc->NIL; ++ sc->outport=sc->NIL; ++ if(is_port(sc->save_inport)) { ++ typeflag(sc->save_inport) = T_ATOM; ++ } ++ sc->save_inport=sc->NIL; ++ if(is_port(sc->loadport)) { ++ typeflag(sc->loadport) = T_ATOM; ++ } ++ sc->loadport=sc->NIL; ++ sc->gc_verbose=0; ++ gc(sc,sc->NIL,sc->NIL); ++ ++ for(i=0; i<=sc->last_cell_seg; i++) { ++ sc->free(sc->alloc_seg[i]); ++ } ++ ++#if SHOW_ERROR_LINE ++ for(i=0; i<=sc->file_i; i++) { ++ if (sc->load_stack[i].kind & port_file) { ++ fname = sc->load_stack[i].rep.stdio.filename; ++ if(fname) ++ sc->free(fname); ++ } ++ } ++#endif ++} ++ ++void scheme_load_file(scheme *sc, FILE *fin) ++{ scheme_load_named_file(sc,fin,0); } ++ ++void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { ++ dump_stack_reset(sc); ++ sc->envir = sc->global_env; ++ sc->file_i=0; ++ sc->load_stack[0].kind=port_input|port_file; ++ sc->load_stack[0].rep.stdio.file=fin; ++ sc->loadport=mk_port(sc,sc->load_stack); ++ sc->retcode=0; ++ if(fin==stdin) { ++ sc->interactive_repl=1; ++ } ++ ++#if SHOW_ERROR_LINE ++ sc->load_stack[0].rep.stdio.curr_line = 0; ++ if(fin!=stdin && filename) ++ sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0); ++#endif ++ ++ sc->inport=sc->loadport; ++ sc->args = mk_integer(sc,sc->file_i); ++ Eval_Cycle(sc, OP_T0LVL); ++ typeflag(sc->loadport)=T_ATOM; ++ if(sc->retcode==0) { ++ sc->retcode=sc->nesting!=0; ++ } ++} ++ ++void scheme_load_string(scheme *sc, const char *cmd) { ++ dump_stack_reset(sc); ++ sc->envir = sc->global_env; ++ sc->file_i=0; ++ sc->load_stack[0].kind=port_input|port_string; ++ sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */ ++ sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd); ++ sc->load_stack[0].rep.string.curr=(char*)cmd; ++ sc->loadport=mk_port(sc,sc->load_stack); ++ sc->retcode=0; ++ sc->interactive_repl=0; ++ sc->inport=sc->loadport; ++ sc->args = mk_integer(sc,sc->file_i); ++ Eval_Cycle(sc, OP_T0LVL); ++ typeflag(sc->loadport)=T_ATOM; ++ if(sc->retcode==0) { ++ sc->retcode=sc->nesting!=0; ++ } ++} ++ ++void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { ++ pointer x; ++ ++ x=find_slot_in_env(sc,envir,symbol,0); ++ if (x != sc->NIL) { ++ set_slot_in_env(sc, x, value); ++ } else { ++ new_slot_spec_in_env(sc, envir, symbol, value); ++ } ++} ++ ++#if !STANDALONE ++void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr) ++{ ++ scheme_define(sc, ++ sc->global_env, ++ mk_symbol(sc,sr->name), ++ mk_foreign_func(sc, sr->f)); ++} ++ ++void scheme_register_foreign_func_list(scheme * sc, ++ scheme_registerable * list, ++ int count) ++{ ++ int i; ++ for(i = 0; i < count; i++) ++ { ++ scheme_register_foreign_func(sc, list + i); ++ } ++} ++ ++pointer scheme_apply0(scheme *sc, const char *procname) ++{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); } ++ ++void save_from_C_call(scheme *sc) ++{ ++ pointer saved_data = ++ cons(sc, ++ car(sc->sink), ++ cons(sc, ++ sc->envir, ++ sc->dump)); ++ /* Push */ ++ sc->c_nest = cons(sc, saved_data, sc->c_nest); ++ /* Truncate the dump stack so TS will return here when done, not ++ directly resume pre-C-call operations. */ ++ dump_stack_reset(sc); ++} ++void restore_from_C_call(scheme *sc) ++{ ++ car(sc->sink) = caar(sc->c_nest); ++ sc->envir = cadar(sc->c_nest); ++ sc->dump = cdr(cdar(sc->c_nest)); ++ /* Pop */ ++ sc->c_nest = cdr(sc->c_nest); ++} ++ ++/* "func" and "args" are assumed to be already eval'ed. */ ++pointer scheme_call(scheme *sc, pointer func, pointer args) ++{ ++ int old_repl = sc->interactive_repl; ++ sc->interactive_repl = 0; ++ save_from_C_call(sc); ++ sc->envir = sc->global_env; ++ sc->args = args; ++ sc->code = func; ++ sc->retcode = 0; ++ Eval_Cycle(sc, OP_APPLY); ++ sc->interactive_repl = old_repl; ++ restore_from_C_call(sc); ++ return sc->value; ++} ++ ++pointer scheme_eval(scheme *sc, pointer obj) ++{ ++ int old_repl = sc->interactive_repl; ++ sc->interactive_repl = 0; ++ save_from_C_call(sc); ++ sc->args = sc->NIL; ++ sc->code = obj; ++ sc->retcode = 0; ++ Eval_Cycle(sc, OP_EVAL); ++ sc->interactive_repl = old_repl; ++ restore_from_C_call(sc); ++ return sc->value; ++} ++ ++ ++#endif ++ ++/* ========== Main ========== */ ++ ++#if STANDALONE ++ ++#if defined(__APPLE__) && !defined (OSX) ++int main() ++{ ++ extern MacTS_main(int argc, char **argv); ++ char** argv; ++ int argc = ccommand(&argv); ++ MacTS_main(argc,argv); ++ return 0; ++} ++int MacTS_main(int argc, char **argv) { ++#else ++int main(int argc, char **argv) { ++#endif ++ scheme sc; ++ FILE *fin; ++ char *file_name=InitFile; ++ int retcode; ++ int isfile=1; ++ ++ if(argc==1) { ++ printf(banner); ++ } ++ if(argc==2 && strcmp(argv[1],"-?")==0) { ++ printf("Usage: tinyscheme -?\n"); ++ printf("or: tinyscheme [<file1> <file2> ...]\n"); ++ printf("followed by\n"); ++ printf(" -1 <file> [<arg1> <arg2> ...]\n"); ++ printf(" -c <Scheme commands> [<arg1> <arg2> ...]\n"); ++ printf("assuming that the executable is named tinyscheme.\n"); ++ printf("Use - as filename for stdin.\n"); ++ return 1; ++ } ++ if(!scheme_init(&sc)) { ++ fprintf(stderr,"Could not initialize!\n"); ++ return 2; ++ } ++ scheme_set_input_port_file(&sc, stdin); ++ scheme_set_output_port_file(&sc, stdout); ++#if USE_DL ++ scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext)); ++#endif ++ argv++; ++ if(access(file_name,0)!=0) { ++ char *p=getenv("TINYSCHEMEINIT"); ++ if(p!=0) { ++ file_name=p; ++ } ++ } ++ do { ++ if(strcmp(file_name,"-")==0) { ++ fin=stdin; ++ } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) { ++ pointer args=sc.NIL; ++ isfile=file_name[1]=='1'; ++ file_name=*argv++; ++ if(strcmp(file_name,"-")==0) { ++ fin=stdin; ++ } else if(isfile) { ++ fin=fopen(file_name,"r"); ++ } ++ for(;*argv;argv++) { ++ pointer value=mk_string(&sc,*argv); ++ args=cons(&sc,value,args); ++ } ++ args=reverse_in_place(&sc,sc.NIL,args); ++ scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args); ++ ++ } else { ++ fin=fopen(file_name,"r"); ++ } ++ if(isfile && fin==0) { ++ fprintf(stderr,"Could not open file %s\n",file_name); ++ } else { ++ if(isfile) { ++ scheme_load_named_file(&sc,fin,file_name); ++ } else { ++ scheme_load_string(&sc,file_name); ++ } ++ if(!isfile || fin!=stdin) { ++ if(sc.retcode!=0) { ++ fprintf(stderr,"Errors encountered reading %s\n",file_name); ++ } ++ if(isfile) { ++ fclose(fin); ++ } ++ } ++ } ++ file_name=*argv++; ++ } while(file_name!=0); ++ if(argc==1) { ++ scheme_load_named_file(&sc,stdin,0); ++ } ++ retcode=sc.retcode; ++ scheme_deinit(&sc); ++ ++ return retcode; ++} ++ ++#endif ++ ++/* ++Local variables: ++c-file-style: "k&r" ++End: ++*/ +diff --git a/bootshell/scheme.h b/bootshell/scheme.h +new file mode 100644 +index 0000000..fbc542b +--- /dev/null ++++ b/bootshell/scheme.h +@@ -0,0 +1,255 @@ ++/* SCHEME.H */ ++ ++#ifndef _SCHEME_H ++#define _SCHEME_H ++ ++#include <stdio.h> ++ ++#ifdef __cplusplus ++extern "C" { ++#endif ++ ++/* ++ * Default values for #define'd symbols ++ */ ++#ifndef STANDALONE /* If used as standalone interpreter */ ++# define STANDALONE 1 ++#endif ++ ++#ifndef _MSC_VER ++# define USE_STRCASECMP 1 ++# ifndef USE_STRLWR ++# define USE_STRLWR 1 ++# endif ++# define SCHEME_EXPORT ++#else ++# define USE_STRCASECMP 0 ++# define USE_STRLWR 0 ++# ifdef _SCHEME_SOURCE ++# define SCHEME_EXPORT __declspec(dllexport) ++# else ++# define SCHEME_EXPORT __declspec(dllimport) ++# endif ++#endif ++ ++#if USE_NO_FEATURES ++# define USE_MATH 0 ++# define USE_CHAR_CLASSIFIERS 0 ++# define USE_ASCII_NAMES 0 ++# define USE_STRING_PORTS 0 ++# define USE_ERROR_HOOK 0 ++# define USE_TRACING 0 ++# define USE_COLON_HOOK 0 ++# define USE_DL 0 ++# define USE_PLIST 0 ++#endif ++ ++/* ++ * Leave it defined if you want continuations, and also for the Sharp Zaurus. ++ * Undefine it if you only care about faster speed and not strict Scheme compatibility. ++ */ ++#define USE_SCHEME_STACK ++ ++#if USE_DL ++# define USE_INTERFACE 1 ++#endif ++ ++ ++#ifndef USE_MATH /* If math support is needed */ ++# define USE_MATH 1 ++#endif ++ ++#ifndef USE_CHAR_CLASSIFIERS /* If char classifiers are needed */ ++# define USE_CHAR_CLASSIFIERS 1 ++#endif ++ ++#ifndef USE_ASCII_NAMES /* If extended escaped characters are needed */ ++# define USE_ASCII_NAMES 1 ++#endif ++ ++#ifndef USE_STRING_PORTS /* Enable string ports */ ++# define USE_STRING_PORTS 1 ++#endif ++ ++#ifndef USE_TRACING ++# define USE_TRACING 1 ++#endif ++ ++#ifndef USE_PLIST ++# define USE_PLIST 0 ++#endif ++ ++/* To force system errors through user-defined error handling (see *error-hook*) */ ++#ifndef USE_ERROR_HOOK ++# define USE_ERROR_HOOK 1 ++#endif ++ ++#ifndef USE_COLON_HOOK /* Enable qualified qualifier */ ++# define USE_COLON_HOOK 1 ++#endif ++ ++#ifndef USE_STRCASECMP /* stricmp for Unix */ ++# define USE_STRCASECMP 0 ++#endif ++ ++#ifndef USE_STRLWR ++# define USE_STRLWR 1 ++#endif ++ ++#ifndef STDIO_ADDS_CR /* Define if DOS/Windows */ ++# define STDIO_ADDS_CR 0 ++#endif ++ ++#ifndef INLINE ++# define INLINE ++#endif ++ ++#ifndef USE_INTERFACE ++# define USE_INTERFACE 0 ++#endif ++ ++#ifndef SHOW_ERROR_LINE /* Show error line in file */ ++# define SHOW_ERROR_LINE 1 ++#endif ++ ++typedef struct scheme scheme; ++typedef struct cell *pointer; ++ ++typedef void * (*func_alloc)(size_t); ++typedef void (*func_dealloc)(void *); ++ ++/* num, for generic arithmetic */ ++typedef struct num { ++ char is_fixnum; ++ union { ++ long ivalue; ++ double rvalue; ++ } value; ++} num; ++ ++SCHEME_EXPORT scheme *scheme_init_new(); ++SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free); ++SCHEME_EXPORT int scheme_init(scheme *sc); ++SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc); ++SCHEME_EXPORT void scheme_deinit(scheme *sc); ++void scheme_set_input_port_file(scheme *sc, FILE *fin); ++void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end); ++SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin); ++void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end); ++SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin); ++SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename); ++SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd); ++SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname); ++SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args); ++SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj); ++void scheme_set_external_data(scheme *sc, void *p); ++SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value); ++ ++typedef pointer (*foreign_func)(scheme *, pointer); ++ ++pointer _cons(scheme *sc, pointer a, pointer b, int immutable); ++pointer mk_integer(scheme *sc, long num); ++pointer mk_real(scheme *sc, double num); ++pointer mk_symbol(scheme *sc, const char *name); ++pointer gensym(scheme *sc); ++pointer mk_string(scheme *sc, const char *str); ++pointer mk_counted_string(scheme *sc, const char *str, int len); ++pointer mk_empty_string(scheme *sc, int len, char fill); ++pointer mk_character(scheme *sc, int c); ++pointer mk_foreign_func(scheme *sc, foreign_func f); ++void putstr(scheme *sc, const char *s); ++int list_length(scheme *sc, pointer a); ++int eqv(pointer a, pointer b); ++ ++ ++#if USE_INTERFACE ++struct scheme_interface { ++ void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value); ++ pointer (*cons)(scheme *sc, pointer a, pointer b); ++ pointer (*immutable_cons)(scheme *sc, pointer a, pointer b); ++ pointer (*reserve_cells)(scheme *sc, int n); ++ pointer (*mk_integer)(scheme *sc, long num); ++ pointer (*mk_real)(scheme *sc, double num); ++ pointer (*mk_symbol)(scheme *sc, const char *name); ++ pointer (*gensym)(scheme *sc); ++ pointer (*mk_string)(scheme *sc, const char *str); ++ pointer (*mk_counted_string)(scheme *sc, const char *str, int len); ++ pointer (*mk_character)(scheme *sc, int c); ++ pointer (*mk_vector)(scheme *sc, int len); ++ pointer (*mk_foreign_func)(scheme *sc, foreign_func f); ++ void (*putstr)(scheme *sc, const char *s); ++ void (*putcharacter)(scheme *sc, int c); ++ ++ int (*is_string)(pointer p); ++ char *(*string_value)(pointer p); ++ int (*is_number)(pointer p); ++ num (*nvalue)(pointer p); ++ long (*ivalue)(pointer p); ++ double (*rvalue)(pointer p); ++ int (*is_integer)(pointer p); ++ int (*is_real)(pointer p); ++ int (*is_character)(pointer p); ++ long (*charvalue)(pointer p); ++ int (*is_list)(scheme *sc, pointer p); ++ int (*is_vector)(pointer p); ++ int (*list_length)(scheme *sc, pointer vec); ++ long (*vector_length)(pointer vec); ++ void (*fill_vector)(pointer vec, pointer elem); ++ pointer (*vector_elem)(pointer vec, int ielem); ++ pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel); ++ int (*is_port)(pointer p); ++ ++ int (*is_pair)(pointer p); ++ pointer (*pair_car)(pointer p); ++ pointer (*pair_cdr)(pointer p); ++ pointer (*set_car)(pointer p, pointer q); ++ pointer (*set_cdr)(pointer p, pointer q); ++ ++ int (*is_symbol)(pointer p); ++ char *(*symname)(pointer p); ++ ++ int (*is_syntax)(pointer p); ++ int (*is_proc)(pointer p); ++ int (*is_foreign)(pointer p); ++ char *(*syntaxname)(pointer p); ++ int (*is_closure)(pointer p); ++ int (*is_macro)(pointer p); ++ pointer (*closure_code)(pointer p); ++ pointer (*closure_env)(pointer p); ++ ++ int (*is_continuation)(pointer p); ++ int (*is_promise)(pointer p); ++ int (*is_environment)(pointer p); ++ int (*is_immutable)(pointer p); ++ void (*setimmutable)(pointer p); ++ void (*load_file)(scheme *sc, FILE *fin); ++ void (*load_string)(scheme *sc, const char *input); ++}; ++#endif ++ ++#if !STANDALONE ++typedef struct scheme_registerable ++{ ++ foreign_func f; ++ const char * name; ++} ++scheme_registerable; ++ ++void scheme_register_foreign_func_list(scheme * sc, ++ scheme_registerable * list, ++ int n); ++ ++#endif /* !STANDALONE */ ++ ++#ifdef __cplusplus ++} ++#endif ++ ++#endif ++ ++ ++/* ++Local variables: ++c-file-style: "k&r" ++End: ++*/ +-- +2.1.4 + |