s9/000755 001751 001751 00000000000 12245412570 011023 5ustar00nmhnmh000000 000000 s9/CHANGES000644 001751 001751 00000213354 12245100023 012011 0ustar00nmhnmh000000 000000 Change Log 2013-11-26 Added ARGV primitive to core system. See below. (s9.c) 2013-11-24 Added ENVIRON and SYSTEM primitives to the core interpreter. (s9.c) Mostly to use minimal S9 in web programming. 2013-04-10 Added a workaround for plan9's atol() function, which interprets leading '0' as octal. Thanks, Bakul Shah! (s9.c) 2013-02-09 Fix: FORMAT-TIME emitted wrong month name with ~@m. Thanks, Doug Currie! (ext/) 2013-01-22 Fix: S9E would abort when exiting from the [^L][e] prompt using backspace. (contrib/) 2013-01-17 Added COLLECT procedure. (lib/) 2013-01-14 Fix: SYNTAX-RULES could abort while matching an ellipsis against an atom. (lib/) 2013-01-09 S9E: Fixed highlighting of marked regions in side-scrolled lines. (contrib/) 2013-01-02 Added experimental "hard" cutting (TRY/CUT) to AMK. (lib/) Added the N-Queens program (using AMK). (contrib/) 2012-12-26 Added numeric goals to AMK. (lib/) 2012-12-22 More changes to AMK for compatibility with the upcoming version of the book. (lib/) 2012-12-20 Made AMK always return () or (()) when no variable was given in RUN*. (lib/) 2012-12-17 Added color customization to S9E. (contrib/) 2012-12-12 Cleaned up AMK, made it more compatible with the book. (lib/) Fix: REM-PROP reversed its property list argument. (lib/) 2012-12-10 Finished S9E, the new S9 Editor with integrated REPL buffer. (contrib/) 2012-12-05 Made DEFINE-MACRO an alias of DEFINE-SYNTAX. (s9.c) 2012-12-02 Fix: GENSYM had a potential race condition resulting in a wrong prefix. (s9.c) Checked for similar race conditions due to string/vector pool compaction; seems clean. 2012-11-30 Fix: SUBSTRING had a GC race condition, which could result in the extraction of garbage. (s9.c) 2012-11-27 Added SRFI-43-compliant VECTOR-COPY and VECTOR-APPEND primitives. (s9.c, s9.scm) 2012-11-26 Fix: REM-PROP failed to remove properties from empty lists. (lib/) Removed SYS:LCHOWN and SYS:LUTIMES system calls. Caused only portability issues. (ext/) 2012-11-25 Added S9SYMBOLS program (dump symbols from help pages). (prog/) 2012-11-24 Added "-i -" (don't load heap image) option. (s9.c) 2012-11-18 Added color support to GET-LINE. (ext/) Added more key codes to GET-LINE. (ext/) 2012-11-15 Added CURS:KEY-DC (delete-char key), CURS:KEY-IC (insert-char key), and CURS:KEY-END constants. (ext/) 2012-11-14 Fix: swapped fore/background arguments of CURS:COLOR-SET. (ext/) 2012-11-13 Fix: PACKAGE was lacking an import of FILTER. (lib/) Fix: test process created wrong image file. (util/) Thanks, Doug Currie! 2012-11-12 Added color support to the curses extension. (ext/) Added the CURS:COLOR-SET and CURS:HAS-COLORS primitives. (ext/) Updated the help pages. 2012-11-11 Simplified creation of top-level bindings. (s9.c, s9.h) Removed SYNTAX? predicate. (s9.c) Added -P (prolog) and -E (epilog) options to EDOC. (prog/) Changed web color scheme. (util/) 2012-11-09 Factored out CHAR-PLOT from RUNTIME-STATS. (ext/, lib/) Made CHAR-CANVAS a package. (lib/) Made RUNTIME-STATS a package. (ext/) 2012-11-08 Made IOTA accept a second argument. (lib/) Added the CHOOSE procedure. (lib/) Added the CURRYR (curry-right) macro. (lib/) 2012-11-07 Made GENSYM accept a symbolic argument. (s9.c) 2012-11-04 Added extra LDFLAGS for OSX. Thanks, Doug Currie! Fix: (lambda x ...) did not work in SYNTAX-RULES. (lib/) 2012-11-02 Fixed a potential memory leak in SYS:EXECVE. (ext/) Made (the still broken) SYNTAX-RULES alpha-rename variables of named LET and DO. (lib/) 2012-11-01 Added LIST-COPY and TAKE procedures. (lib/) Renamed GROUP-LIST to GROUP, swapped arguments to be more consistent with other list procedures. (lib/) Reverted EQUAL? to comparing vectors by converting them to lists first. (s9.c) 2012-10-30 Renamed QUEUE and UNQUEUE to QUEUE! and UNQUEUE!. (lib/) Updated help pages. Cleaned up cooperative threads procedures and fixed last thread exit problem. (lib/) Made the interpreter reset the TTY when exiting after an error. (s9.c) Added more EQUAL? tests. (util/) 2012-10-27 Added a SIGTERM handler to reset the TTY when curses support is compiled in. (s9.c) 2012-10-22 Optimized DRAW-TREE. (contrib/) 2012-10-21 Cleaned up DRAW-TREE code. (contrib/) 2012-10-19 Fixed order of assignment in FLUID-LET. (lib/) 2012-10-17 Made IOTA a single-argument procedure. (lib/) Renamed IMPORT keyword of simple-modules to USING. (lib/) 2012-10-16 Fix: SCM2HTML did not reset color after comments in quoted objects in string-input mode. (s9.c) 2012-10-14 Suppressed trailing blanks when stopping run-away output. (s9.c) Fixes bounds checking in multi-dimensional ARRAYs. (lib/) 2012-10-13 Fix: NUMBER->STRING would suppress trailing zeroes in expanded real numbers. E.g.: (number->string 1.23e5) ==> "123". Oops! (s9-real.scm) 2012-10-11 Made SCM2HTML accept upper case # syntax, e.g.: #F. (contrib/) 2012-10-11 Made BIT-OP variadic. (s9.c) Added BIT-OP operations 16 (shift left) and 17 (shift right). (s9.c) 2012-10-10 Made EQUAL? cons-free when comparing vectors. (s9.scm) 2012-10-09 Made the reader and printer abort processing of suspiciously deeply nested lists and vectors. Thanks to dig1 and bsamograd on reddit! (s9.c, s9.h) Made EDOC generate back links only in level-0 headings. (prog/) 2012-10-05 Now accepting [...] as an alias of (...). (s9.c) Updated SCM2HTML to handle [...] properly. (contrib/) Updated test suite. (util/) Fix: STANDARD-ERROR-PORT was documented as STANDARD-ERROR. (help/) 2012-10-04 Fix: error reporting was broken by interruptible printer. (s9.c) 2012-10-03 Made WRITE and DISPLAY primitives interruptible. (s9.c) Passed help files through spell-checker. (lib/, contrib/, prog/, help/, edoc/) 2012-10-02 Added "variable index" command to EDOC. (prog/) Added REAL type to TYPE-OF and TYPE-CASE. (lib/) 2012-09-29 Added "non-printing index" command to EDOC. (prog/) 2012-09-25 Added "unreadable" syntax (#) to SCM2HTML. (contrib/) 2012-09-24 Fixed quotation in SCM2HTML. (contrib/) Added -t (tilde-quotes) flag to SCM2HTML1. (prog/) 2012-09-22 Added style for invisibly quoted forms to SCM2HTML. (contrib) 2012-09-21 Added the TILDE-QUOTES option to SCM2HTML. (contrib/) Made EDOC pass 'TILDE-QUOTES: #T to SCM2HTML. (prog/) 2012-07-09 Changed webdump color scheme. (util/) Adapted web theme to current home page. (util/) Updated the man page. (s9.1) Misc. cosmetical changes. (lib/) 2012-07-08 Renamed SOS to S9SOS - S9 Simple Object System. (contrib/) Replaced the '!image' option by '-i image'. (s9.c) Allowed to specify an image source file with '-i'; made the LIBRARY option obsolete. (s9.c) Cleaned up some meta files. 2012-07-06 Fixed more typos. 2012-07-05 Removed the ARSE development environment, because it has a design bug that makes it crash when undoing changes near the top or bottom of a file. Fixed a few typos. Fix: BIT-OP could overflow on 64-bit systems. (s9.c) 2011-05-11 Cleaned up the Unix/POSIX/XOPEN Mambo Jambo prelude. (s9.h) Added some casts to make later GCCs happy. (s9.c, s9-real.c) (unreleased.) 2010-11-13 Fix: sudden allocation of large vector failed, even if enough vector space was present (this did not happen when allocating lots of small vectors, releasing them, and then allocating a large vector). (s9.c) 2010-10-29 Fix: missing hash-table reference in memoize.scm. (lib/) 2010-10-11 Added GET-PROP, PUT-PROP, etc. (lib/) 2010-10-08 Added STRING-PREFIX=? and STRING-PREFIX-CI=? procedures. (lib/) 2010-10-07 Fix: MAKE-STRING and MAKE-VECTOR did not check for negative arguments. (s9.c) 2010-10-06 Added TIME-ADD, TIME-SUBTRACT, TIME-DIFFERENCE, TIME-BEFORE?, and TIME-AFTER? procedures. (lib/) Moved SWAP! to "setters.scm"; removed "swapb.scm". (lib/) 2010-10-05 Added small-magnitude bit operators (bitops). (lib/) 2010-10-04 Renamed BITWISE-AND-NOT --> BITWISE-NOT-AND, BITWISE-OR-NOT --> BITWISE-NOT-OR, BITWISE-XOR-NOT --> BITWISE-NOT-XOR. (lib/) Added fast bit operations (BIT-OP). (s9.c) 2010-10-03 Misc. minor changes. This is the book version. 2010-09-29 Applied minor change to RIB internal structure. (s9.c) 2010-09-27 Added \i (image) mode to EDOC. (prog/) 2010-09-23 Added "NIL" and "@ rest" syntax to MAKE-MATCHER. (lib/) 2010-09-22 Added line concatenation via \\ to EDOC, made EDOC's -b option link to a file given on the command line instead of hardwiring "index.html". (prog/) 2010-09-21 Changed MAKE-MATCHER semantics. Once again. :-/ But this time it will be final! (lib/) Moved the MAKE-MATCHER code to the EDOC section. (lib/, edoc/) 2010-09-19 Re-organized the "primitives" section. (s9.c) 2010-09-16 Moved SYNTAX-RULES to EDOC section. (lib/, edoc/) 2010-09-13 EDOC: Improved layout of Lout output; still experimental, though! (prog/) 2010-09-11 Fixed some minor 64-bit/prototyping glitches. (s9*.c) 2010-09-10 Added HTMLIFY-CHAR and LOUTIFY-CHAR to library. (lib/) Started Lout backend in EDOC. (prog/) 2010-09-09 EDOC: improved error messages, implemented strict mode (being picky about matching braces). (prog/) 2010-09-07 Fixed botched optimization in EXP function. (s9-real.scm) 2010-09-06 Cleaned up real number primitives. (s9-real.c) 2010-09-05 DISPLAY/WRITE now round the last digit of real numbers with large mantissas, so 1.99999999999999997 actually prints as 2.0 on 32-bit systems. (s9-real.scm) Added INC!, DEC!, and SET-VARS! syntax. (lib/) 2010-09-04 Factored out CHECK-BINDINGS and SPLIT-BINDINGS in the Scheme core. (s9.scm) Fix: a quotation char ('`,) followed by a closing paren swallowed that closing paren. (s9.c) 2010-09-03 Fix: APPEND accepted atoms in positions other than the last. (s9.scm) PRETTY-PRINT now prints (and), (or), and (begin) more nicely. (contrib/) 2010-09-02 Allowed nested quasiquotation as long as an embedded QUASIQUOTE is inside of UNQUOTE or UNQUOTE-SPLICING. (s9.scm) Applied more optimizations to MAKE-MATCHER. (lib/) Added GROUP-LIST procedure to library. (lib/) Fix: WITH-OUTPUT-TO-FILE always returned #. (s9.scm) 2010-09-01 Made STRING and VECTOR primitives. (s9.c) Fix: SYS:READLINK did not NUL-terminate its return string. (ext/) Optimized internal accessors of MAKE-MATCHER. (lib/) 2010-08-31 Changed PACKAGE syntax and semantics. (lib/) Added Red-Black Trees. (lib/) Various small changes. (s9.c) 2010-08-29 Changed MAKE-MATCHER syntax. (lib/) Retired ML-MATCH syntax. (lib/) 2010-08-26 Applied various cosmetics and micro-optimizations. (s9.c) 2010-08-25 Changed environment box model from (name . (value)) to (name . value), (ab?)using the CDR field as a box. This saves quite a few conses during evaluation. (s9.c) Improved syntax checking in local DEFINEs. (s9.c) Added detection of improper lists (syntax errors) in special forms. (s9.c) 2010-08-24 Made STATS primitive expand macros before evaluation. (s9.c) 2010-08-22 Fix: Made EXPT return an inexact number when passed an inexact argument, because conversion lost digits. Also made SQRT return an inexact result. (s9-real.scm) 2010-08-20 Documented EDOC using EDOC. (prog/) Fix: counting newlines in block comments. (s9.c) 2010-08-19 SCM2HTML: added support for block comments. (s9.c) 2010-08-15 Fix: all real numbers must be inexact according to R4RS. (s9.c) Fixed a precision bug in mixed bignum/real operations. (s9-real.c) Fixed missing trailing zero in (number->string 1.0). (s9-real.scm) 2010-08-14 Cleaned up SCM2HTML program. (contrib/) Added C2HTML program. (contrib/) 2010-08-13 Changed interface of SCM2HTML and moved it to contrib/. Added SCM2HTML1 program (SCM2HTML wrapper). (prog/) Fix: (+ 0.0 -1.0e-999999999) gave 0.0. (s9-real.c) Fix: (+ #e0.0 #e1.0e-999999999) gave an inexact result. (s9-real.c) 2010-08-12 ARSE: made [d][/]x and [d][?]x repeatable. (contrib/) Added ,q (sys:exit) meta command. (s9.c) Added #| ... |# comments. (s9.c) 2010-08-10 Tweaked real number interface (internal). (s9*.[ch]) Updated the man page. (s9.1) 2010-08-09 Finished integration of big real number support. (*.c, *.scm) 2010-08-08 Re-integrated big real arithmetics. (*.[ch], *.scm) Added real number test suite. (util/) 2010-08-07 Added make-cats.scm program and CATEGORIES.html file. (util/) 2010-08-06 ARSE: fix: clear undo log when loading a different file into an edit buffer. (contrib/) 2010-08-03 Fix: (,x) was interpreted as a meta command. (s9.c) Fix: SYNTAX-RULES failed to detect some syntax errors before ellipses. (lib/) S9 SOS: make instantiation invalid. (contrib/) Added 'COMPRESS: option to RUNTIME-STATS. (ext/) 2010-08-02 Applied some cosmetics to SYNTAX-RULES. (lib/) Added LISTQ syntax. (lib/) Made APPEND fold to the right (O(n) instead of (O(n^c) when appending multiple lists). (s9.scm) Added COLS program. (prog/) 2010-08-01 CHAR-CANVAS: auto-clipping out-of-range coordinates. (lib/) RUNTIME-STATS: misc. small fixes. (ext/) 2010-07-31 Added plotter and table formatter to RUNTIME-STATS. (ext/) Fixed CANVAS-PLOT-LINE. (lib/) 2010-07-30 Added the RUNTIME-STATS procedure to library. (ext/) Added SWAP! syntax to library. (lib/) Added character-based canvas to library. (lib/) 2010-07-29 Made STATS return a list instead of printing its data. (s9.c) Added SYS:GETTIMEOFDAY extension procedure. (ext/) Added TIME procedure to library. (/ext) Fixed S9 SOS built-in hierarchy. (contrib/) 2010-07-28 Added meta commands, which are entered by typing a #\, at the top level and without any enclosing parens. See S9(1) for details. (s9.c) 2010-07-27 Added PUSH! and POP! macros. (lib/) Added PACKAGE macro. (lib/) 2010-07-26 Removed UNDEFINED primitive; causes only trouble. (s9.c) Added minor optimizations to MAKE-MATCHER. (lib/) Made MAKE-MATCHER and ML-MATCH two separate packages. (lib/) 2010-07-25 Made S9 not count initial GC in STATS. (s9.c) Added cons cell statistics to interpreter. (s9.c) Fix: SYNTAX-RULES failed to expand stuff following "...". (lib/) 2010-07-24 Added TREE-MAP procedure. (lib/) Fix: RE-MATCH returned wrong format when processing REs beginning with "^" in combination with 'ALL. (lib/) 2010-07-23 Finished the S9 SOS and its documentation. (contrib/) 2010-07-21 Made ":set regex" default in ARSE. (contrib/) 2010-07-20 Bootstrapped SOS. (contrib/) 2010-07-19 ARSE: removing output that begins with ";" when reloading a buffer. (lib/) 2010-07-18 Added first sketch of SOS (Scheme Object System). (contrib/) Added 'REVERSE keyword to T-SORT; added T-SORT-NET. (lib/) Added 'TOP-DOWN option to T-SORT. (lib/) ARSE: added "scheme-init" option. (contrib/) 2010-07-17 Added 'CONVERT-UNREADABLE option to READ-FROM-STRING. (lib/) Added help pages for the REVERSE!, STATS, SYNTAX?, TRACE, VOID, and UNDEFINED procedures. (help/) 2010-07-16 Added UNDEFINED procedure; see s9(1). (s9.c) 2010-07-15 Added KEYWORD-VALUE procedure. (lib/) Rewrote HASH-TABLE, added support for 'SIZE and 'TEST keywords. (lib/) Added WHEN, UNLESS, WHILE, and UNTIL syntax. (lib/) ARSE: made [TAB] insert blanks when not typing a symbol. (contrib/) 2010-07-14 Added DUPLICATES procedure and friends. (lib/) DEFINE-STRUCTURE not reports duplicate slot names. (lib/) 2010-07-13 Added queue data type. (lib/) 2010-07-12 Added MEMOIZE procedure and DEFINE-MEMOIZED syntax. (lib/) 2010-07-11 Added ID (identity) procedure. (lib/) ARSE: added regex support to [/] and [?] commands. (contrib/) Re-organized library. (lib/) Added check-descr.scm to check descriptions for web dump. (util/) 2010-07-10 Added SPLIT and MERGE procedures, rewrote MERGESORT. (lib/) Fixed stuck state (0) in RANDOM-STATE. (lib/) Fix: SYS:MAKE-INPUT-PORT and SYS:MAKE-OUTPUT-PORT could return a closed port due to GC. (ext/) Rewrote BITWISE-... operators. (lib/) Added INTEGER->BINARY-STRING and BINARY-STRING->INTEGER. (lib/) Fix: RE-SUBST generated wrong matches with trailing "\\)". (lib/) 2010-07-09 ARSE: fixed spurious trailing lines after undo. (contrib/) ARSE: added regular expression support (:s). (contrib/) Added COMPOSE, COMPLEMENT, TRUE, and FALSE procedures. (lib/) Added RANDOM and RANDOM-STATE procedures. (lib/) 2010-07-08 Added SYNTAX? primitive. (s9.c) Added T-SORT (topological sort) procedure. (lib/) Added EQUAL-CI? procedure. (lib/) Added TYPE-OF procedure and TYPE-CASE syntax. (lib/) Added ASSP and MEMP procedures. (lib/) Applied various small fixes to PRETTY-PRINT. (contrib/) Updated man page. (s9.1) 2010-07-07 Added RE-SUBST procedure to REGEX package. (lib/) Added TREE-COPY procedure. (lib/) 2010-07-06 Added auto-completion to ARSE. (contrib/) Added ADJOIN, SET-DIFFERENCE, and SUBSET? procedures. (contrib/) Added -COPY procedure to DEFINE-STRUCTURE. (lib/) Replaced lots of REVERSEs with REVERSE!. (*) 2010-07-05 Added POSITION and friends to library. (lib/) ARSE: fixed tab expansion; added "unexpand" option. (contrib/) 2010-07-04 Added the AMB (backtracking) operator. (lib/) Added HASH-TABLE-REMOVE! and ALIST->HASH-TABLE; renamed HASH-TABLE->LIST to HASH-TABLE->ALIST. (lib/) Fix: (cond ('(()))) was an error. (s9.c) 2010-07-03 Fix: FOR-ALL sometimes returned #T unexpectedly. (lib/) Fix: CALL/CC could crash AND, BEGIN, COND, and OR. :-/ (s9.c) Added ARRAY-MAP procedure. (lib/) 2010-07-02 Added more array operations. (lib/) 2010-07-01 Added Common LISP-style CATCH/THROW. (lib/) Added ARRAYs and array operations. (lib/) 2010-06-30 Renamed DEFINE-RECORD to DEFINE-STRUCTURE, allowed simpler slot syntax. (lib/) 2010-06-29 ARSE: reload main buffer automatically when recovering from a REPL error. (s9.c) ARSE: fix: undo delete lines at end of buffer. (contrib/) 2010-06-28 Renamed EXPAND-MACRO to MACRO-EXPAND (more CL'ish). (s9.c) Added MACRO-EXPAND-1 procedure. (s9.c) Added Common LISP TAGBODY to library. (lib/) 2010-06-27 Added CALL-WITH-CURRENT-CONTINUATION (CALL/CC). (s9.c) Related critical change in s9.c:_eval(): name = car(rib_source(rib)); - /* Save result */ - car(Stack) = Acc; if (Trace_list != NIL) Imported CALL/CC description from R4RS. (help/) Added LET/CC to library. (lib/) Added cooperative thread functions. (lib/) Removed CALL-WITH-ESCAPE-CONTINUATION. 2010-06-26 Added REVERSE! primitive and used in some places. (s9.c, s9.scm) Made (re-match (re-comp "^") "foo") ==> ((0 0)) and (re-match (re-comp "$") "foo") ==> ((3 3)). (lib/) Added 'ALL option to RE-MATCH. (lib/) Added VECTOR-MAP, made VECTOR-MAP! variadic. (lib/) Added STRING-MAP and STRING-MAP!. (lib/) 2010-06-25 Made S9 ignore SIGPIPE, so the SYS: procedures can catch broken pipe conditions themselves. (ext/) ARSE: ignore broken pipe condition when writing to REPL. (contrib/) ARSE: added autocenter option. (contrib/) Cleaned up the REGEX procedures and added submatches. (lib/) Made RE-MATCH return ranges rather than strings. (lib/) 2010-06-24 Misc. clean-up. 2010-06-23 Factored out all the S9fES stuff in ARSE, so it can be ported to other Schemes more easily. (contrib/) ARSE: [r] did not check autoindent option. (contrib/) Added ARSE porting instructions. (contrib/) Added VECTOR-MAP! and STRING-SCAN procedures. (lib/) ARSE: expanding tabs to spaces when reading filters, etc. (contrib/) 2010-06-22 Added DEFINE-RECORD syntax. (lib/) (DEFINE-SYNTAX (F ...) ) accepted only a single-expression body. Fixed that. (s9.c) ARSE: no longer displaying the REPL buffer when reloading or recompiling. (contrib/) ARSE: some general clean-up. (contrib/) 2010-06-21 Finished Unix extension test suite. (util/) Documented SYS:SLEEP, SYS:USLEEP. (help/) 2010-06-20 SYS:CHOWN did not work. (ext/) ARSE: :s//... did not allow leading blanks in . (contrib/) ARSE: missing REAL-POS! in SUBSTITUTE and COLON-READ. (contrib/) Added SYS:SLEEP, SYS:USLEEP procedures. (ext/) 2010-06-19 Removed SYS:LCHMOD; not portable. (ext/) Cleaned up symlinks in help directory. (help/) 2010-06-18 Fix: hash tables did not allow negative numeric keys. (lib/) 2010-06-17 Added a quick and dirty dependency checking mode to S9RESOLVE. (prog/) Fixed some unresolved library dependencies. ;-) * Explanation: * The default image file contains most of the S9fES library * functions, so it does not really need all those LOAD-FROM-LIBRARY * calls. However, I consider it to be good style to make library * dependencies explicit by adding them anyway. S9RESOLVE -d detects * missing LOAD-FROM-LIBRARYs. 2010-06-16 Factored out FIND-HELP-PATH procedure. (ext/) Added SPAWN-SHELL-COMMAND procedure. (ext/) SPAWN-COMMAND has new semantics, SPAWN-SHELL-COMMAND implements the old behavior. (ext/) Added more missing symlinks to help directory. (help/) 2010-06-14 Added the SYS:FILENO procedure. (ext/) Fix: SYS:SELECT sometimes returned #F even when some descriptors were ready. (ext/) Fix: PP-FILE could not find LINEFEED procedure. (contrib/) Made the pretty-printer indent embedded IF, COND, etc in code mode rather than data mode. (contrib/) 2010-06-13 Removed CURS:KEY-EOL from curses, because it is not the key labeled "END" on a PC keyboard. Which KEY_ constant is used for this key? My /usr/include/curses.h says KEY_SELECT, but this does not appear to make sense. (ext/) 2010-06-12 Made READ-FROM-STRING skip over comments in multi-line input. (contrib/) Added SYS:CATCH-ERRORS and SYS:STRERROR primitives. (ext/) Made SPAWN-COMMAND redirect stderr of the spawned command to stdout so it can be read by the parent. (ext/) Added URL-DECODE procedure to library. (lib/) 2010-06-11 Added the PP-STRING procedure to the pretty-printer. (contrib/) 2010-06-10 Added the INET-SERVER procedure to the extension library. (ext/) Rewrote S9HTS using INET-SERVER. (prog/) Reinstalled and fixed a load of wrong or missing symlinks in help directory. (help/) 2010-06-09 Added the SPLIT-URL procedure to the library. (lib/) 2010-06-08 Added SYS:INET-GETPEERNAME primitive to Unix extension. (ext/) Implemented S9HTS, a simple HTTP server. (prog/) Added STRING-POSITION and friends to library. (lib/) Added STRING-LAST-POSITION and friends to library. (lib/) 2010-06-06 Added the CURSES_RESET compile time option, which will run CURS:ENDWIN automatically in the REPL, so Curses cannot hose the interface in interactive sessions. Of course, when using this option, (CURS:INITSCR) will not have any effect when entered at the REPL. (s9.c) Moved ARSE (was: SCHED) to contrib/, kept only the command line interface in prog/. Added ARSE installation procedure to Makefile. Documented ! option. (s9.1) Fix: not all globals were initialized in PRETTY-PRINT. (contrib/) Fix: PP printed a lonely closing paren in intended applications with no arguments. (contrib/) 2010-06-05 Added !image option to change the heap image name ad hoc. (s9.c) 2010-06-02 Fixed a few bugs in ADVGEN; it only worked due to the below bug in S9. :-/ 2010-06-01 Fix: Local environments of *dynamically* scoped (a.k.a. top-level) procedures were still being propagated to functions called *iff* there were multiple levels of local definitions in the top-level procedure, e.g.: (define (g) x) (define (f) (let ((x 0)) (let () ; <-- this triggered the bug (g) #f))) (f) ==> 0 ; should be an error (x undefined) This is definitely fixed now. Regression test added. (s9.c) 2010-05-31 Intercepted more funny characters. (s9.c) 2010-05-30 Made STRING->NUMBER accept base prefixes. (s9.scm) Replaced some applications of the obsolete WRONG procedure with applications of ERROR. (s9.scm) Made the interpreter identify funny input characters. (s9.c) 2010-05-28 Fixed a GC bug introduced by growing the pools independently. This bug was triggered by using more vector space than node space. (s9.c) Improved the stress test suite. (util/) 2010-05-27 ADVGEN: renamed GO/RET to GO/SEL. (prog/) Tweaked the sample adventure. (prog/) 2010-05-26 S9 now takes its image name from argv[0] instead of hardwiring it. (s9.[ch]) Added new FORMAT help page with better explanations and lots of examples; try (help 'format). (help/) 2010-05-25 Fix: FORMAT recursed indefinitely in case of an error due to re-use of the name ERROR. (contrib/) 2010-05-24 Added expansion template to AND-LET* description. (lib/) Added Curses interface help pages. (help/) Added CURS:LINES and CURS:COLS procedures. (ext/) Fix: MAKE-STRING did not type-check second argument. (s9.c) 2010-05-23 Added first version of a CURSES(3) interface. (ext/) Fixed GC bug in APPEND2. Made cons and vector pools grow independently. (s9.c) 2010-05-22 Stopped interpreter from reporting infinite sequences of '(' in error messages, even if the reported structure is cyclic. Added AND-LET*. (lib/) Minor cosmetics. 2010-05-21 Improved limited output in error messages. (s9.c) Running "make tests" will now use a minimum heap image, so unresolved references in the library will be detected. (Makefile) Improved ADVGEN error messages. (prog/) Added COPY-FROM special description to ADVGEN. (prog/) 2010-05-20 Made DEFINE-SYNTAX an alias for DEFINE-MACRO; removed DEFINE-MACRO. (s9.c) Moved SYNTAX-RULES to the extension library. (lib/) Added the STANDARD-ERROR-PORT, WITH-OUTPUT-TO-STDERR, and CALL-WITH-STDERR procedures. (ext/) Limited size of Scheme objects in error messages. (s9.c) Updated S9(1) man page and help pages. (help/) Various small fixes and cosmetics. 2010-05-19 Added GO/RET operator to ADVGEN. (prog/) Applied various minor improvements to the pretty-printer. (contrib/) Added default values to PARSE-OPTIONS!. (ext/) Added SCMPP pretty-print utility. (prog/) Added more features to ADVGEN; see prog/advgen.txt. 2010-05-18 Fixed a long-standing bug that caused the following program to evaluate to 1: (define (g) x) (define (f) (let ((x 1)) (g) #f)) (f) This happened only if (g) was *not* a tail call. The critical part of the fix is: + if (!tail && cdr(Environment) != NIL) + Environment = cdr(Environment); in s9.c:bind_arguments(). 2010-05-17 Added ADVGEN documentation, fixed some minor bugs. (prog/) 2010-05-16 Added GO/CUT operator to ADVGEN. (prog/) Added STRING-FIND-LAST, STRING-FIND-LAST-WORD, STRING-CI-FIND-LAST, STRING-CI-FIND-LAST-WORD. (lib/) Fix: SCM2HTML did no longer accept input from stdin. (prog/) Fix: SCM2HTML rendered #[bdox] literals in wrong color. (prog/) Fix: ADVGEN: stupid bug in HTML postlude. (prog/) Fix: SCM2HTML: #\$ is a valid symbol character. (prog/) Added missing symlinks to help database. (help/) 2010-05-15 Documented NAME->FILE-NAME. (contrib/) Added code to install utility programs. (Makefile) Added COUNTER option type and "--" special argument to PARSE-OPTIONS!. (ext/) Added ADD/GO and REM/GO actions to ADVGEN. (prog/) 2010-05-14 Added new option types to PARSE-OPTIONS!. (ext/) 2010-05-13 Added STRING-TRANSLATE procedure to library. (lib/) Finished sample ADVGEN adventure. (prog/) Fixed a bug in PARSE-OPTIONS!: option args were always taken from first option. Oops. (lib/) 2010-05-12 Fixed names in error messages of CAAR..CDDDDR. (s9.c) Implemented first version of ADVGEN, an HTML adventure generator. (prog/) 2010-05-11 Made email addresses in the code harder to harvest. 2010-05-10 Added HTMLIFY utility. (prog/) Added stuff for automatic web site creation. (util/) 2010-05-09 Renamed all UNIX:... symbols to SYS:... and made naming more consistent. All names in the SYS-UNIX extension now begin with SYS:. (ext/) Moved SYS:FLUSH with no args to library (FLUSH-OUTPUT-PORT). (ext/) Added LETREC* syntax. (lib/) 2010-05-08 While I am at it: made these procedures primitives: APPEND, LIST-TAIL, MIN, MAX. (s9.c, s9.scm) Fixed READ-FROM-STRING (mixed up some numbers and symbols). (lib/) Added #B, #D, #O, #X prefixes to READ-FROM-STRING. (lib/) Renamed STRING-FIND to STRING-LOCATE and STRING-CONTAINS to STRING-FIND. Also swapped the arguments of STRING-FIND so that STRING-FIND and STRING-LOCATE are more consistent now. (lib/, contrib/) Added [+-][st] modifiers to CHANGE-MODE. (ext/unix.scm) 2010-05-07 Made these procedures primitives: ABS, ASSQ, ASSV, CAAR..CDDDDR, EQV?, EVEN?, LENGTH, LIST, MEMQ, MEMV, NEGATIVE?, NOT, NULL?, ODD?, POSITIVE?, REVERSE, ZERO?. Resulting speed increase is between 30% (libtest) and 70% (htmlize library). (s9.c, s9.scm) Added -9 (highlight non-R4RS symbols) and -x (highlight extensions) arguments to SCM2HTML utility. (prog/) Added indentation of DO. (contrib/pretty-print.scm) Fixed evluation of DO in PROGRAM?: allowed more than one statement in body, made statement in termination clause optional. (lib/programp.scm) 2010-05-06 Made DRAW-TREE print more compact trees by emitting the conses of (...(x)...) as soon as possible. (contrib/draw-tree.scm) Added interactive mode to SOCCAT program. (prog/) Added UNIX:ACCESS help page. 2010-05-05 Added purely functional streams to library. (lib/streams.scm) Added UNIX:WAITPID procedure. Fixed type checking in UNIX:KILL (accepted single argument). Added the SOCCAT utility. (prog/soccat) 2010-05-04 Added UNIX:SELECT procedure. 2010-05-03 Made argument of FLUSH optional (defaults to current output port). Added UNIX:INET-CONNECT, UNIX:INET-LISTEN, and UNIX:INET-ACCEPT procedures. Made UNIX:* procedures print more informative error messages. Added mode argument to UNIX:MKDIR, made it optional in MKDIR. 2010-05-02 Made UNIX:STAT not follow symlinks. Added STRING-CONTAINS-WORD and STRING-CI-CONTAINS-WORD. (lib/) Added FIND-HELP procedure. (ext/) Made PARSE-OPTIONS! accept symbolic options (instead of strings). 2010-05-01 Added UNIX:SETUID, UNIX:SETGID. UNIX:GETPGID, UNIX:SETPGID. Added DISPLAY*. (lib/) 2010-04-30 Added the UNIX:FORK, UNIX:WAIT, and UNIX:EXECV procedures. Added the UNIX:ACCESS and SEARCH-PATH procedures. (ext/) Replaced the primitive UNIX:SPAWN and SPAWN procedures with the high-level SPAWN-COMMAND procedure. (ext/spawn-command.scm) Added S9RESOLVE program, which resolves S9fES library dependencies. (prog/) Hash tables sizes now adapt automatically. (lib/hash-table.scm) 2010-04-29 Added more Unix procedures: UNIX:CLOSE, UNIX:CREAT, UNIX:DUP, UNIX:DUP2, UNIX:LSEEK, UNIX:MAKE-INPUT-PORT, UNIX:MAKE-OUTPUT-PORT, UNIX:OPEN, UNIX:PIPE, UNIX:READ, UNIX:WRITE, UNIX:UMASK. Also added the APPEND-TO-OUTPUT-FILE procedure. (ext/) 2010-04-28 Added PARSE-OPTIONS! and friends. (ext/parse-options.scm) Installing contribs directly in @LIBDIR@ now. Made UNIX:READDIR skip the "." and ".." entries. Added UNIX:RENAME procedure. 2010-04-27 Added the STRING-UNSPLIT procedure (lib/). Made HASH-TABLE-REF return just a value (lib/hash-table.scm). Error messages are now printed on stderr when the interpreter runs in quiet mode (-q). Added DIRNAME procedure. Moved contrib/pretty-print.scm to prog/scm2html.scm and made it a stand-alone program. Moved S9 configuration from Makefile to config.scm. 2010-04-26 Added help pages for all remaining UNIX: procedures. Added the STAT-type? predicates for finding out the type of a directory entry. Added the BASENAME procedure. Removed the S9U(1) man page, because it basically duplicates the help pages. Added "programs" section (prog/) and dupes program. 2010-04-25 Added "pattern=mode" to UNIX:CHMOD. Added some UNIX: procecures to the help database. Added STRING-PARSE procedure. Made STRING-SPLIT generate empty strings when multiple subsequent separators are found. Updated S9U(1) man page (was S9E(1) man page). Updated help pages. 2010-04-24 Merged S9 and S9E interpreters; configure in Makefile. Added third return value (PID) to UNIX:SPAWN. Added UNIX:KILL and KILL procedures. Added R4RS test cases to test suite. 2010-04-23 Removed real number stuff. Removed Scientific Calculator stuff. Removed statistics package. ------------------------------------------------------------------------ Forked this version. ------------------------------------------------------------------------ 2009-09-06 Removed EXPAND-QUASIQUOTE. It is no longer needed, because EXPAND-MACRO can now be used to expand quasiquoted forms. Documented the interpreter start-up process in the man page. Renamed WRONG to ERROR to make it more compatible with SRFI-23 error reporting. 2009-09-05 Rewrote QUASIQUOTE as a macro and removed all quasiquotation functionality from the C part. 2009-09-03 Included "./lib" and "./contrib" in DEFAULT_LIBRARY_PATH, so S9 can load libraries after just compiling it in its build directory. Added the S9:S9 start-up hook. When a nullary procedure named S9:S9 exists, it will be called when S9 starts. Added the DUMP-IMAGE primitive, which allows to write a new heap image from the REPL. Updated the help pages. 2009-09-02 Made SQRT return an exact value whenever possible. 2009-08-14 Fix: '() printed two ()'s (was introduced with #). Added the UNSORT procedure to LIB. 2009-08-11 Fixes: - Cleaned up the SC extension; - Added missing S9SC(1) man page. Thanks again, Masaru KIMURA. 2009-08-08 Added constants for options, so you can write (plot* -7 7 sin type: scatter style: 3) instead of (plot* -7 7 sin 'type: 'scatter 'style: 3). 2009-08-07 Added 'X-GRID: and 'Y-GRID: options to S9SC SETUP procedure. Added abbreviations, e.g.: 'STEP: for 'X-STEP: and 'Y-STEP:, etc. Fix: second argument of EXPT could not be real. 2009-08-06 Added option argument checking to S9SC procedures. Fix: made PRINT-CODE generate proper links for LOAD-FROM-LIBRARY arguments without ".scm" suffix. 2009-08-05 Wrote the S9SC(1) man page. 2009-08-04 Re-organized the extension libraries. Renamed the GFX extension to SC. Added initialization procedures to extensions. Made (LOG N) return # for non-positive N. 2009-07-26 Fixed some warnings in GFX extension. Thanks, Barak Pearlmutter. 2009-07-25 Added statistics package to CONTRIB. Added the Scheme 9 Scientific Calculator extension (S9SC). Note that S9SC is *very* experimental at this stage. 2009-07-08 Fixed that rounding bug in ATAN. 2009-07-05 Test suite failed on 64-bit machines due strange rounding errors in ATAN. Decreased accuracy to 4 digits as a lame work-around. Suggestions welcome. 2009-07-04 Added support for unspecific digits (#) to STRING->NUMBER. Fix: (ASIN 1) and (ACOS 0) were undefined. Fixed some minor flaws. Added tests for ACOS, ASIN, ATAN, and STRING->NUMBER. 2009-07-01 Added the ACOS, ASIN, ATAN procedures. Fix: real number normalization *first* removed trailing zeros and *then* truncated the mantissa. Oops. 2009-06-29 Added '#' syntax for unspecific digits in inexact numbers. 2009-06-26 Fix: STRING->NUMBER always returned an inexact result for real number representations. 2009-06-25 Fix: Stack was not cleaned up properly in some error conditions. Fix: (*) and (+) could crash the interpreter. Internal: Added 64-bit emulation for 32-bit systems. 2009-06-15 Minor cleanup, added comments where necessary. * Do not expect any updates in the near future. * I need a break from programming. * Bug reports are still welcome, but will get low * priority for now. 2009-06-09 Fixed a variable collision in the hash table implementation. (lib/hash-table.scm) 2009-06-08 Made PRINT-CODE recognize new numeric functions as primitives. Fixed INVERSEO procedure in AMK. 2009-06-07 Made STRING->NUMBER recognize real numbers. Fix: missing initialization of got_d in string_numeric(). Fix: FLOOR and EXACT->INEXACT did not normalize their results. Simplified counter_to_string(), based on code by Masaru KIMURA. Added loads of tests for STRING->NUMBER. 2009-06-06 Extended domain of NUMBER->STRING to REAL. Added support for the "precision markers" D,F,L,S, although only one floating point precision exists. Fix: MANTISSA did not return negative signs. Fix: INEXACT->EXACT lost the sign of its operand. Fix: #I created a double sign in negative integers. Added/updated help pages for various procedures. Added more tests. 2009-06-05 Fix: SIN, COS, TAN expected degrees, should be radians. Oops. Ran further 64-bit tests on the Alpha, all passed. 2009-06-04 Implemented LOG and EXP procedures. Added tests. Fixed size of Called_procedures[]. Good catch, Masaru KIMURA. 2009-06-03 Implemented CEILING, FLOOR, ROUND, TRUNCATE procedures. Implemented SIN, COS, and TAN procedures. Added tests for all of the above. Made procedures expecting integers accept real numbers too, as long as they are exact and can be converted to integer without loss of precision. Added tests. Made the reader accept an excess number of digits in the mantissa, giving an inexact number. 2009-06-02 * I have tested this release on my Alpha with -DBITS_PER_WORD_64 * and it passed all tests. If make test still fails on Linux/PPC, * I would need SSH access to a PPC box to investigate further. Implemented SQRT. Fixed INTEGER? (mistook random objects for integers). Removed some 64-bit glitches. Applied some cosmetics. Added test cases. 2009-06-01 Implemented real number division (/). Made INTEGER? return #T for reals that can be converted to integer without loss of precision. Made INEXACT->EXACT return an integer whenever possible. Extended domain of EXPT to real. Implemented the internal EXPONENT and MANTISSA procedures. Fixed a GC leak in real_normalize(). Thanks, Masaru KIMURA. Added test cases for / and EXPT. Added more type test cases. Updated the S9(1) man page. 2009-05-31 Implemented real number multiplication (*). Just try: (expt 9.9 999999999). Is this cool? Intercepted numeric underflow and overflow. Added test cases for real *. Added #E and #I syntax. Added real number test cases for #E, #I, EXACT->INEXACT, INEXACT->EXACT, NEGATIVE?, POSITIVE?, ZERO?. 2009-05-30 Fixed INEXACT->EXACT (sign error). Implemented real -. Implemented exactness in - the +, MIN, and MAX procedures; - bignum-->real conversion; - real number normalization. Added real number tests for -, ABS, MIN, MAX. Added test cases for EXACT->INEXACT and INEXACT->EXACT. 2009-05-29 Implementated real +. Implemented EXACT? and INEXACT?. Implemented EXACT->INEXACT and INEXACT->EXACT. Fixed a few bugs in real <. Added real number tests for +. 2009-05-28 Added more test cases for real <. Extended domains of <=, >, >= to real. Added real number tests for <=, >, and >=. * Please stress-test the real number routines * and do report errors! * Suggestions for additional tests are welcome! 2009-05-27 Added mantissa size to magic ID of image files. Implemented comparison of real numbers in <. Added real number tests for <. 2009-05-26 Moved sign of reals to flags field in order to allow for -0.0. Changed flat_copy() so that it can copy special atoms, too. Added real number tests for =. Cleanup. 2009-05-25 Added a reader and printer for real numbers. Implemented internal representation for real numbers. Implemented comparison of real numbers in =. Added more syntax tests to test suite (primarily in order to test the real number reader and printer). Added REAL? predicate. Made NUMBER? an alias of REAL?. Applied some minor cosmetics. * Note that you cannot yet do anything really useful with * real numbers other than translating them from/to external * representation and comparing them. 2009-05-24 Added code to detect real number syntax and dispatch it to a specialized reader. Yes, this is a first step toward real number arithmetics, but don't hold your breath right now. 2009-05-23 Improved the documentation of the matcher package. Removed unused list_of_symbols() function from "s9.c". Thanks, Masaru KIMURA (also for misc. other cosmetics). 2009-05-22 Moved "define-match.scm" to "matcher.scm". Renamed DEFINE-MATCH to DEFINE-MATCHER, added LET-MATCHER syntax to matcher package. Extended matchers so that 'SYMBOL matches a literal symbol. (lib/matcher.scm) Improved rendering of (cond (p => x)) in pretty printer. (contrib/pretty-print.scm) Applied various cosmetics. 2009-05-21 Added STRING-UPCASE and STRING-DOWNCASE procedures. (lib/string-case.scm) 2009-05-20 Simplified HASH-TABLE procedures. (lib/hash-table.scm) 2009-05-17 Included help pages for ALL procedures of the extension library! Just try (load-from-library "draw-tree") and then (help 'draw-tree). LOAD-FROM-LIBRARY now attaches a ".scm" suffix, if the given file cannot be located, i.e., you can write (load-from-library "foo") instead of (... "foo.scm"). Tweaked the image dump/load routines. Fixed a (self-made) bug in FORMAT (~A would slashify output). 2009-05-16 Fix: made strings returned by SYMBOL->STRING immutable. Updated the help pages. Prepared comments in library files for automatic generation of help pages. (Stay tuned.) 2009-05-14 Added code to grow the memory pools when loading large images. Added interpreter tag to magic header (images are not portable). Added another tweak for POSIX compatibility. 2009-05-13 Administrative: - Removed all those special variables ($@, $<, ...) from Makefile, because some(?) of them are simply not portable. - Added -Dunix to compilation of unix.c (sic!). 2009-05-12 Applied some cosmetics to s9.scm. Administrative: fixed local environment in the build process. 2009-05-11 Fix: PRINT-CODE handled QUOTE inside of QUASIQUOTE incorrectly. (contrib/print-code.scm) Fixed a bug that resulted in multiple evaluation of DELAYed expressions. 2009-05-10 Minor fix: protected car(x) in syntax_object_p(). Cosmetics. Changed allocation strategy. We will now use half of the memory pool at most. OK, this gives us the same space efficiency as a copying collector, but with the advantage of having cons objects in fixed places on the heap. The performance gain is about 35% (zebra puzzle). 2009-05-09 Minor fix: protected argument in pp_load(). Made conceptual difference between string and symbol names [string() vs. symbol_name(), string_len() vs. symbol_len()]. Removed clone_string() due to above separation. Using O(1) string_len() instead of O(n) strlen() in pp_gensym(). Checking length first in STRING=? and STRING-CI=?. 2009-05-07 Fix: PRINT-CODE generated tag soup when two subsequent tokens were to be printed in boldface. Added another tweak for Unix portability to s9.h. 2009-05-06 Administrative change: - #ifdef __unix and #ifdef unix are obviously insufficient to check for a Unix system; added -Dunix to Makefile. Thanks, Barak Pearlmutter! 2009-05-05 Administrative changes: - Applied some fixes to the build process. - Created browsable version of the library code. - Added version tag (timestamp) to distribution file. - Added deinstall target to Makefile. 2009-05-04 Replaced '| by ': in ML-style syntax of DEFINE-MATCH, because '| is not portable. Removed MAP-CAR from documentation, because it is only used internally. Simplified definition of LETREC (cosmetics). Made the code printer generate links to files included via LOAD-FROM-LIBRARY. (contrib/print-code.scm) 2009-05-03 Added a pattern matcher with optional support for ML syntax to the library. (lib/define-match.scm) Updated the test suite. Moved the online help system to contrib. (contrib/help.scm) Moved DRAW-TREE to contrib. (contrib/draw-tree.scm) Included the pretty-printer and the online help system in the default heap image. 2009-05-01 Fixed some 64-bit flaws. Many thanks to Torsten Leibold for giving his AlphaStation 200 4/233 to me! 2009-04-29 Fix: alpha-conversion of recursive SYNTAX-RULES was broken, leading to potentially non-hygienic expansion. Added SYNTAX-RULES version of FLUID-LET. (lib/fluid-let-sr.scm) Fix: line numbers were off after LOAD. Moved interactive programs to CONTRIB, even if they have been contributed by myself. (pretty-print.scm, print-code.scm) 2009-04-28 Finished the new and vastly improved pretty-printer. (lib/pretty-print.scm) 2009-04-27 Fixed some bugs in PROGRAM? (DO with multi-expr test part was not allowed; commands were not optional). Started rewriting the pretty-printer. 2009-04-26 Reporting file name in messages when using "-f program" option. Made the pretty-printer print '`, and ,@ instead of QUOTE, QUASIQUOTE, UNQUOTE, and UNQUOTE-SPLICING. Still more clean-up. 2009-04-25 Even more code clean-up. 2009-04-23 Applied more cosmetics. 2009-04-22 Improved hashing of lists. (lib/hash-table.scm) Added memoization to PROLOG interpreter. (contrib/prolog.scm) 2009-04-21 Applied various micro optimizations and cosmetics. Added == (unify) and DIF goals to PROLOG example. 2009-04-20 Made the interpreter print file and line number information in error messages when LOADing a file. Reverted to previous version of the PROLOG interpreter due to unclear semantics. 2009-04-19 Extended the PROLOG interpreter. (contrib/prolog.scm) 2009-04-18 Added PROLOG interpreter to contrib section. (contrib/prolog*) 2009-04-15 Fixed some error messages; made messages more uniform. Fixed a bug in the reader: the (malformed) expression (')) gave a strange result. It is an error now. 2009-04-12 Documented the VOID procedure. 2009-04-10 Added numeric base prefixes #B, #D, #O, and #X. 2009-04-09 Fix: STRING-FILL! and VECTOR-FILL! should not be able to mutate string and vector literals, either. 2009-04-08 Added the STATS primitive, which evaluates an expression and then prints some interesting data gathered during evaluation. Added the VOID procedure, which evaluates to an unspecific value. 2009-04-03 Fix: a #F literal following an ellipsis in DEFINE-SYNTAX/SYNTAX-RULES would be substituted by mistake. 2009-03-30 A Debian package was created by Barak Pearlmutter. Thanks for the package and a few minor but useful patches! 2009-03-22 Made pair, string, and vector literals immutable, so expressions like these no longer work: (set-car! '(a b) 'c) (set-cdr! '(a b) 'c) (string-set! "foo" 0 #\g) (vector-set! '#(a b) 0 'c) 2009-03-15 Added code to make S9fES compile with PCC. Wow, PCC is so much faster, still generates good code, and comes with a liberal license. Bye, bye, GCC. 2009-03-14 Added FreeBSD port. Updated s9(1) man page. 2009-03-13 Fix: made quasiquotation of improper lists work. Fix: rewrote the high-level syntax matcher and expander. DEFINE-SYNTAX and SYNTAX-RULES should work as expected now, including multiple ellipses, etc. Made the interpreter report nested QUASIQUOTE (which is currently unsupported). Added UNIX:UNLINK primitive to extended interpreter. (ext/unix.c) 2009-03-12 Made unix extension procedures return #F in case of an error instead of just aborting evaluation. Added UNIX:ERRNO primitive to extended interpreter. (ext/unix.c) Updated README, fixed s9e(1) man page, updated the binary for the unmentionable horror. 2009-03-11 Added UNIX:READDIR and UNUX:READLINK primitives to extended interpreter. (ext/unix.c) Added UNIX:GETPWENT primitive to extended interpreter. (ext/unix.c) 2009-03-10 Added FORMAT-TIME procedure to the system extension. (ext/system.scm) Updated s9e(1) man page. 2009-03-09 Added UNIX-TIME->TIME and TIME->UNIX-TIME procedures to the system extension. (ext/system.scm) 2009-03-08 Fix: removed recursion from GC of vectors. The garbage collector runs completely in constant space now. Yay! 2009-03-03 Made CHOWN accept user names and default values. (ext/system.scm) 2009-03-02 Added UNIX:GETGRNAM and UNIX:GETGRGID primitives to Unix extensions. (ext/unix.c) Added bitwise logic operations to library: BITWISE-CLEAR, BITWISE-AND, BITWISE-AND-C2, BITWISE-1, BITWISE-AND-C1, BITWISE-2, BITWISE-XOR, BITWISE-OR, BITWISE-OR-NOT, BITWISE-XOR-NOT, BITWISE-C2, BITWISE-OR-C2, BITWISE-C1, BITWISE-OR-C1, BITWISE-AND-NOT, BITWISE-SET, BITWISE-SHIFT-LEFT, BITWISE-SHIFT-RIGHT. (lib/bitwise-ops.scm) Made CHMOD accept symbolic and octal modes. (ext/system.scm) Made argument of EXIT optional. (ext/system.scm) 2009-03-01 Made the interpreter abort earlier in case of an error. Added hash table procedures to library. (lib/hash-table.scm) 2009-02-28 Added support for radixes from 2 to 36 to NUMBER->STRING and STRING->NUMBER. Not R4RS, but nice and trivial to implement. Added READ-FILE procedure to library. (lib/read-file.scm) Added STRING-FIND (fast string search) procedure to contrib. (contrib/string-find.scm) 2009-02-27 The code printer now supports vectors. (lib/print-code.scm) New: added contrib directory containing code by other authors. Added Common Lisp-style FORMAT to contrib section. Thanks, Dirk Lutzebäck. (contrib/format.*) 2009-02-26 Fix: the interpreter now accepts newline characters in string literals. Fixed quotation of strings in the WRITE-TO-STRING library procedures. Added DISPLAY-TO-STRING (lib/write-to-string.scm). 2009-02-25 Fix: test part of DO should accept multiple expressions. Added TRACE primitive. See man page for details. Fixed a bug in the PROGRAM? library function (LAMBDA should accept multiple expressions). 2009-02-22 Updated the help pages (included descriptions of dynamic top-level variables). Added the FLUID-LET syntax to the library (lib/fluid-let.scm). 2009-02-09 Updated man page and help entry for DEFINE-MACRO. 2009-02-04 Added support for named LET to the pretty-printer (lib/pretty-print.scm). 2009-02-03 Added the PROGRAM? predicate to the library (lib/programp.scm). Added automatic code/data detection to the pretty-printer (lib/pretty-print.scm). 2009-02-02 Added formatting of DO to the pretty-printer (lib/pretty-print.scm). 2009-02-01 Cleaned up installation process. Fixed vector output and quotation in the pretty-printer (lib/pretty-print.scm). 2009-01-30 Fixed indentation of lambda function applications in the pretty-printer (lib/pretty-print.scm). 2009-01-29 Allowed multiple occurrences of the -f program switch on the command line. Fixed packaging error: library files (lib/) were missing. 2009-01-28 Updated documentation. 2009-01-27 Applied some cosmetical changes (mostly s9.scm). Added some test cases for multiple expressions in bodies. 2009-01-26 Improved syntax checking of LET*. Fix: the else clause of CASE evaluated only the first expression of its body. Fix: DO now binds variables in each iteration rather than mutating them. 2009-01-25 Added the APROPOS procedure to the help system [(load-from-library "help.scm")]. Added a help page for DEFINE-MACRO. 2009-01-24 New: Finished the online help system that is based on the R4RS document. Try (load-from-library "help.scm") and then (help). Use (set! *lines-per-page* ...) to adjust the system to your preferred screen size. Improved DEFINE-SYNTAX and SYNTAX-RULES (added support for multiple ellipses per pattern). DEFINE-SYNTAX is still quirky, though. 2009-01-21 Added the -i (ignore rc file) command line option. 2009-01-20 Fix: SYMBOLS was broken by macro expansion. 2009-01-19 Added STRING-CONTAINS to the library. Factored out the LOCATE-FILE procedure, which locates a file in $S9FES_LIBRARY_PATH (s9.scm). Fixed the implementation of DELAY (it now passes all tests of Aubrey Jaffer's R4RS test suite). 2009-01-18 Added pretty-printer to the library (lib/pretty-print.scm). Added code printer to the library (lib/print-code.scm). The PRINT-CODE procedure renders Scheme code in HTML with syntax highlighting and optional CSS2-based paren matching. 2009-01-17 Added the DRAW-TREE procedure to the library. Fix: bodies of local DEFINEs may have more than one expression now. Fix: interpreter no longer breaks when attempting to expand incomplete quotation and quasiquotation. 2009-01-16 Updated manual pages. Removed FOLD-LEFT and FOLD-RIGHT from the library, because the S9fES core already contains them. Made FOLD-LEFT, FOLD-RIGHT, and map accept lists of different lengths. 2009-01-15 Added ML-style record data type to library (records.scm). Added the SYMBOLS primitive which returns a list of defined symbols. 2009-01-14 Added Another Micro Kanren (amk.scm) and the zebra example (zebra.scm) to the library. Added automatic library testing (libtest.sh). 2009-01-13 Imported the regular expression matcher of zenlisp (lib/regex.scm). Added the STRING-SPLIT, READ-FROM-STRING, AND WRITE-TO-STRING procedures to the library. Fixed DEFINE-SYNTAX: templates now may contain syntactically incorrect binding constructs. Yes, this is important; see lib/module.scm for an example. Added simple module syntax to the library (module.scm). 2009-01-12 Removed the SQRT procedure, because it always returned an integer. This procedure will be included in a future version as INTEGER-SQRT. Added the following procedures to the library of loadable functions: COMBINE, COUNT, DEPTH, EXISTS, EXPLODE, FACTOR, FACTORIAL, FILTER, FLATTEN, FOLD-LEFT, FOLD-RIGHT, FOR-ALL, HYPER, IMPLODE, INTEGER-SQRT, INTERSECTION, IOTA, LIST->SET, MAKE-PARTITIONS, MERGESORT, PARTITION, PERMUTE, QUICKSORT, READ-LINE, REMOVE, REPLACE, SUBSTITUTE, SUM, TRANSPOSE, UNION. 2009-01-11 Fixed a few more routines that relied on fixed string and vector locations and may be broken by vector pool compaction. Potentially affected: DEFINE, DEFINE-MACRO, VECTOR->LIST, STRING->LIST. 2009-01-10 I get bitten by this one over and over again. So, note to myself: C's stupid order of evaluation messes up Car[x] = alloc(foo,bar); because Car may relocate during GC. I have fixed about a dozen instances of this bug in the current version, so if you do not like nasty surprises (a.k.a. GC leaks), you may want to update. 2009-01-07 Fix: LOAD-FROM-LIBRARY did not work, because LOAD added bindings to the current local environment instead of the global environment. Loading files should be faster now, because environments are re-hashed only once per LOAD. 2009-01-06 Made s9 -v output more verbose. Added LOAD-FROM-LIBRARY procedure. Documented internal dynamic variables. 2009-01-02 Changed allocator strategy. The size of new segments grows exponentially now (n^1.5), resulting in a smaller initial memory footprint, smaller heap image, and faster adaption to memory-intensive applications. Changed default memory limit to 12.1M bytes (was 1M bytes). 2009-01-01 Cleaned up the DEFINE-SYNTAX transformer (s9.scm). Fix: the evaluator could block when running out of nodes. Added -m size (set memory limit) command line option. 2008-12-14 Applied some cosmetics. 2008-12-13 Added -g (GC summaries) command line option. 2008-12-12 Fixed missing procedure name in some error messages. 2008-12-09 The interpreter returns to the REPL now when hitting the memory limit (MEMORY_LIMIT_KN). Changed types of all references to nodes from int to cell in order to improve support for 64-bit systems. Renamed SYS extension to UNIX. 2008-12-08 A system called Scheme 9 should run on Plan 9, indeed. Thanks to Bakul Shah for pointing this out and helping me to get it ported. Thanks to Russ Cox for 9vx. 2008-11-29 Cleaned up the extension procedure interface. Adding new primitives should be a snap now. 2008-11-28 Cleaned up (internal) definitions of primitive procedures. 2008-11-26 Moved constant, variable, and macro declarations to a header file (s9.h). 2008-11-05 Fixed a subtle GC bug related to string cloning. Potentially affected: STRING-COPY, SYMBOL->STRING, STRING->SYMBOL. 2008-11-01 Fixed SYS:COMMAND-LINE (would destroy the command line when called). Cleaned up the build/install process. 2008-10-06 Fixed a bug that could crash S9 when DEFINEing variables in hashed environments. Thanks, Doug Currie. 2008-09-05 Documented the SYS extension (see s9e(1)). 2008-09-04 Applied some cosmetics to the syntax rules expander and added an example (s9.scm). 2008-09-03 Applied some cosmetical changes to the C code. Cleaned up much of the Scheme code. Included experimental SYS extension (see ext/* and EXTENSIONS in s9.c). Documented PRINT. Added else clause to COND-EXPAND. Documented COND-EXPAND. Added some macro expansion tests to the test suite. 2007-10-30 Removed SYNTAX->LIST because it is no longer needed. 2007-10-27 The interpreter is now printing a call trace in case of an error. 2007-10-23 Fix: DISPLAY can now output NUL characters. (OK, this is not really covered by R5RS, but useful, nevertheless.) 2007-10-19 Extended domain of INTEGER->CHAR to 0..255. 2007-10-17 Fix: WRITE-CHAR could not output NUL characters. 2007-10-14 Fix: interpreter core-dumped when $HOME was undefined. 2007-10-07 Fix: LOAD does not change (CURRENT-INPUT-PORT) any longer. 2007-10-06 READ now requires string literals to be contained in a single line of input. 2007-10-01 Improved error reporting in DO, LET, and LETREC. Allowed multiple expressions in bodies of CASE and improved error reporting. 2007-09-28 Removed record primitives from the interpreter, because they can be implemented portably. 2007-09-25 Removed redundant clauses from FOLD-LEFT and FOLD-RIGHT. Fixed a bug in the syntax checker of SYNTAX-RULES. ------------------------------------------------------------------------ Major change: re-implemented DEFINE-SYNTAX/SYNTAX-RULES ------------------------------------------------------------------------ 2007-09-23 Applied some cosmetical changes to DEFINE-SYNTAX. 2007-09-21 Added some syntax analysis and error reporting to DEFINE-SYNTAX. 2007-09-20 Added optional string argument to GENSYM. This argument is used as a prefix in generated symbols. Added an experimental implementation of DEFINE-SYNTAX and SYNTAX-RULES in terms of DEFINE-MACRO. Added header to image file format. 2007-09-14 Updated the man page. 2007-09-13 Added RECORD-TYPE-MATCHES?. 2007-09-12 Added record tests to test.scm. 2007-09-11 Added (record-copy record) => record. Added (record-signature record) => sig. Added (assert-record-type sig record) => record. 2007-09-10 Added first-class records as an experiment, including the following items: - Record syntax and external representation: #r((tag value ...)). - EQUAL? now applies RECORD-EQUAL? to pairs of records. - New procedures: - (record '(tag value) ...) => record - (record? expr) => boolean - (record->list record) => list - (list->record list) => record - (record-ref record tag) => form - (record-set! record tag value) => unspecific - (record-equal? record1 record2) => boolean 2007-09-09 Fix: SIGINT could not interrupt runaway macro expansion. 2007-09-08 Added support for extension procedures (ext/*, experimental, not yet in the distribution archive). 2007-09-04 Cleaned up the LET macro. Documented macros (S9(1)). Extended and cleaned up the test suite. 2007-09-03 Removed EXPAND-SYNTAX procedure. Added EXPAND-MACRO procedure. Added DO macro. Added heap image support for faster start-up. Added => syntax of COND. Added named LET syntax. 2007-09-02 Removed DEFINE-SYNTAX and SYNTAX-RULES. It is too cumbersome for some purposes and too complex internally. Implemented DEFINE-MACRO. Added GENSYM procedure, because it is required to write some macros. Rewrote LET, LETREC, LET*, CASE, DELAY using DEFINE-MACRO. ------------------------------------------------------------------------ Major change: switching from DEFINE-SYNTAX to DEFINE-MACRO ------------------------------------------------------------------------ 2007-08-29 Misc. small, cosmetical changes. 2007-08-20 Achieved a speed-up of about 10% by the use of hash chaining. Fix: heavy computations involving large lists of integers could crash the interpreter during GC. Thanks, Mario Deilmann. 2007-08-09 Made somes changes to support 64-bit architectures (not yet finished). Fixed two nasty bugs that potentially could crash the interpreter. 2007-08-06 Made OPEN-OUTPUT-PORT fail when the output file already exists. This change also affects CALL-WITH-OUTPUT-FILE and WITH-OUTPUT-TO-FILE. Added DELETE-FILE and FILE-EXISTS? procedures althouth they are not R5RS procedures, because they are simply too handy for testing file access procedures. 2007-08-05 Removed segment matches from the syntax expander, because this is not required by R5RS, so (x ... y) is not longer a valid pattern in SYNTAX-RULES. Fix: the body of COND clauses may be empty. Fix: made #\SPACE and #\NEWLINE case-insensitive. Fix: CALL-WITH-INPUT-FILE and CALL-WITH-OUTPUT-FILE did not close their ports before returning. Removed #\LINEFEED (not in R5RS). Fix: made LIST? detect cyclic structures. Removed R6RS-style comments. Made the test suite more general, so that it does not make assumptions about behavior not specified in R5RS. 2007-07-21 Fix: Syntax expansion was done after quasiquote expansion, but should have done before it. 2007-07-18 Fixed a bug in _bignum_divide(): a GC leak could occur when the divisor was greater than the dividend. 2007-07-16 Simplified test suite using DEFINE-SYNTAX. It is smaller, cleaner, and also siginificantly slower now (due to syntax transformation overhead). 2007-07-06 Applied some minor, mostly cosmetical changes to s9.c. 2007-07-04 Fix: STRING-APPEND did not check the types of its arguments. 2007-07-03 Fixed some comments, renamed some variables. 2007-07-01 Simplified read_c() and turned it into a macro. 2007-06-30 Changed representation of #, # and # from symbol to integer (optimization). Simplified atomp_p() and made it a macro. Directed all interpreter output through pr(). 2007-06-29 Fixed a bug in the syntax expander. 2007-05-26 Adding hash tables broke **. Fixed that. 2007-05-22 Added hash tables to environments for faster lookup speed. Fix: the sane environment was not GC-safe in the REPL. 2007-05-11 Fix: `'(,(+ 1 2)) reduced to '(,(+ 1 2)). It now (correctly) reduces to '(3). 2007-05-05 Fix: clauses of CASE could not contain multiple expressions. 2007-04-26 Made missing program file an error condition in -f program command line option. 2007-04-24 Fix: local ports of WITH-INPUT-FROM-FILE and WITH-OUTPUT-TO-FILE were not GC-safe. Added -q (quiet) command line option. Updated man page. 2007-04-21 Made more cosmetical changes. 2007-04-20 Made some minor cosmetical changes. 2007-04-19 Simplified evaluator (saved one unsave/save). 2007-04-18 Added patches to make s9.c compile on newer MSC compilers. Thanks, Blake McBride. De-cluttered code by replacing #ifdefs with ifs. Added 64-bit mode for bignum integers for faster operation on 64-bit systems. Fixed LET* with multiple expression body. 2007-04-15 Added error condition for DEFINE in expression context. Updated test suite. 2007-04-14 Implemented local DEFINEs by rewriting them to LAMBDA and SET! (like LETREC). Added rc file support: if a ~/.s9fes/rc file exists, it is loaded at start-up time. Updated test suite. Updated man page. 2007-04-13 Implemented QUASIQUOTE, UNQUOTE, and UNQUOTE-SPLICING. Added EXPAND-QUASIQUOTE to library. This procedure rewrites quasiquoted expressions to expressions not using quasiquotation. Note: you currently cannot quasiquote improper lists. 2007-04-12 Documented ** (most recent top level result). Created a distribution archive. Added "install" target to Makefile. 2007-04-11 Added "additions" section to man page. It describes the non-R5RS procedures of S9fES. Applied some minor optimizations to EXPAND-SYNTAX. Moved part of syntax transformation code into s9.c. Added DELAY and FORCE to library. Added ** symbol, which always binds to the result most recently returned to the REPL. 2007-04-10 Added SIGINT (abort input or interrupt program) and SIGQUIT (emergency exit) handlers. If your system does not support POSIX signals, compile with -DNO_SIGNALS to omit signal handling. Added -ansi -pedantic compilation flags, removed some flaws. Implemented DEFINE-SYNTAX and SYNTAX-RULES special form handlers. Added SYNTAX->LIST helper (non-R5RS; used in syntax expansion). Added EXPAND-SYNTAX (non-R5RS), which performs syntax transformation behind the scenes. Note: This is an import of the potentially buggy SketchyLISP syntax transformer. To be improved. Added CASE syntax to library. Added LET* syntax to library. Updated test suite. 2007-04-09 Added to library: STRING, VECTOR. Added to library: NUMBER->STRING, STRING->NUMBER. Added to library: CALL-WITH-INPUT-FILE, CALL-WITH-OUTPUT-FILE, newline, WITH-INPUT-FROM-FILE, WITH-OUTPUT-TO-FILE. Updated test suite. Added -f program command line option. Added s9(1) man page. 2007-04-08 Added library s9.scm which is automatically loaded. Added list procedures to library: APPEND, ASSOC, ASSQ, ASSV, CAAR...CDDDDR, LENGTH, LIST, LIST-REF, LIST-TAIL, LIST?, MEMBER, MEMQ, MEMV, NULL?, REVERSE. Added equivalence predicates to library: EQUAL?, EQV?. Added type predicate to library: NUMBER?, PORT?. Added NOT procedure to library. Added higher order procedures to library: FOR-EACH, MAP, FOLD-LEFT (R6RS), FOLD-RIGHT (R6RS), MAP-CAR (non-R5RS). Added arithmetic functions to library: ABS, EVEN?, EXPT, GCD, LCM, MAX, MIN, MODULO, NEGATIVE?, ODD?, POSITIVE?, SQRT, ZERO?. Updated test suite. 2007-04-07 Implemented CHAR-DOWNCASE, CHAR-LOWER-CASE?, CHAR-NUMERIC?, CHAR-UPCASE, CHAR-UPPER-CASE?, CHAR-WHITESPACE?. Implemented STRING-LENGTH, STRING-REF, STRING-SET!. Implemented STRING-APPEND, STRING-COPY, STRING-FILL!, SUBSTRING. Fixed a bug in string/vector pool compaction. Implemented MAKE-STRING, MAKE-VECTOR, VECTOR-FILL!. Implemented <=, >, >=. Updated test suite. 2007-04-06 Implemented OPEN-INPUT-FILE, OPEN-OUTPUT-FILE, CLOSE-INPUT-PORT, CLOSE-OUTPUT-PORT. Made the garbage collector close unused ports. Implemented SET-INPUT-PORT!, SET-OUTPUT-PORT!, both non-R5RS. These will facilitate the implementation of WITH-INPUT-FROM-FILE and WITH-OUTPUT-TO-FILE. Fix: made READ-CHAR and PEEK-CHAR return the EOF object on EOF. Implemented CHAR-CI<=?, CHAR-CI=?, CHAR-CI>?, CHAR<=?, CHAR=?, CHAR>?. Implemented STRING-CI<=?, STRING-CI=?, STRING-CI>?, STRING<=?, STRING=?, STRING>?. Updated test suite. 2007-04-05 Implemented I/O ports. Implemented CURRENT-INPUT-PORT AND CURRENT-OUTPUT-PORT. Implemented INPUT-PORT?, OUTPUT-PORT?, EOF-OBJECT?. Fixed sign error in * with odd numbers of arguments. Updated test suite. Implemented READ, WRITE, DISPLAY. Implemented READ-CHAR, WRITE-CHAR, PEEK-CHAR. 2007-04-04 Chased a GC bug due to C's braindead order of evaluation. Growing memory pools work fine now. Fixed some potential GC leaks in the bignum code. Made QUOTIENT and REMAINDER handle negative signs correctly. Brought test suite up to date. 2007-04-03 Started test suite. Fixed a few bugs in cond. Implemented SET-CAR!, SET-CDR!, AND VECTOR-SET!. Implemented growing memory pools. 2007-04-02 Moved most of the type checking code to a central procedure. Implemented type predicates: BOOLEAN?, CHAR?, INTEGER?, PAIR?, PROCEDURE?, STRING?, SYMBOL?, VECTOR?. Implemented type conversion procedures: CHAR->INTEGER, INTEGER->CHAR, LIST->STRING, LIST->VECTOR, STRING->LIST, STRING->SYMBOL, SYMBOL->STRING, VECTOR->LIST. Implemented vector procedures: VECTOR-LENGTH, VECTOR-REF. Implemented WRONG (non-R5RS). Implemented integer (bignum) =. Implemented CHAR=? and STRING=?. 2007-04-01 Implemented COND. Implemented LOAD. 2007-03-31 Implemented integer (bignum) *, QUOTIENT, and REMAINDER. 2007-03-30 Implemented LETREC. Started implementation of bignum arithmetics. Implemented integer (bignum) <, +, -. 2007-03-29 Implemented CONS, CAR, CDR, EQ?. Simplified the garbage collector. Removed tedious and buggy variable capture code from lambda. 2007-03-28 Chased a GC leak, found it, splat! --> * Implemented primitive procedure framework. Implemented APPLY. 2007-03-27 Implemented DEFINE (dynamically scoped!). Fixed a few bugs in variable capture (could not test this earlier). Implemented let by rewriting it as an application of LAMBDA. 2007-03-26 Modified the evaluator to get rid of the L-stack. Modified the evaluator to get rid of the B-stack. Implemented BEGIN, IF, AND, OR, and SET!. 2007-03-25 Imported the evaluator from Sketchy LISP. S9fES can now run ((lambda (x) (x x)) (lambda (x) (x x))). In constant space! 2007-03-24 Implemented lambda abstraction. 2007-03-23 Took the garbage collector, reader, and printer from Sketchy LISP and gave them an overhaul. S9fES supports R6RS-style #|...|# and #;form comments. s9/LICENSE000644 001751 001751 00000002127 12075001322 012020 0ustar00nmhnmh000000 000000 Scheme 9 from Empty Space A Portable Scheme Interpreter with a Unix Interface By Nils M Holm, 2007-2013 This code is free. FREE! What's so hard to understand about this? It is in public domain. Neither mine nor yours. Do whatever you want with it! The following section in short means: "If this code should break something, don't blame me." Just in case. Disclaimer: THIS SOFTWARE IS PROVIDED BY THE AUTHOR 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 AUTHOR 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. s9/Makefile000644 001751 001751 00000016262 12245412567 012500 0ustar00nmhnmh000000 000000 # Scheme 9 from Empty Space # Makefile (obviously) # By Nils M Holm, 2007-2012 # Placed in the Public Domain. # Change at least this line: PREFIX= /u # Override default compiler and flags CC= gcc CFLAGS= -g -Wall -ansi -pedantic -O2 # You may try one of the following, if you get "wrong interpreter" errors #LDFLAGS+= -Wl,-no_pie #LDFLAGS+= -no_pie #LDFLAGS+= -fno_pie # Which OS are we using (unix or plan9)? OSDEF= -Dunix # Uncomment these to include the Unix extensions EXTRA_SCM+= -l ext/unix.scm EXTRA_OBJS+= unix.o EXTRA_INIT+= sys_init(); EXTRA_LIBS+= # Uncomment these to include the Curses extensions EXTRA_SCM+= -l ext/curses.scm EXTRA_OBJS+= curses.o EXTRA_INIT+= curs_init(); EXTRA_LIBS+= -lcurses # Uncomment this and add REALNUM to DEFS (below) to include # real number arithmetics EXTRA_SCM+= -l s9-real.scm # Options to be added to $(DEFS) # -DBITS_PER_WORD_64 # use 64-bit bignum arithmetics # -DNO_SIGNALS # disable POSIX signal handlers # -DREALNUM # enable real number arithmetics # # (requires "s9-real.scm" EXTRA_SCM, above) # -DDEFAULT_LIBRARY_PATH="\"dir:...\"" # # default search path for LOCATE-FILE # -DNETWORK # include socket code in the Unix extension # -DCURSES_COLOR # enable the CURS:SET-COLOR primitive # -DCURSES_RESET # automatically run CURS:ENDWIN on the REPL # # (requires the Curses extension) DEFS= $(OSDEF) \ -DDEFAULT_LIBRARY_PATH="\".:~/s9fes:$(LIBDIR)\"" \ -DEXTENSIONS="$(EXTRA_INIT)" \ -DREALNUM \ -DNETWORK \ -DCURSES_COLOR \ -DCURSES_RESET # Where to install the stuff BINDIR= $(PREFIX)/bin LIBDIR= $(PREFIX)/share/s9fes MANDIR= $(PREFIX)/man/man1 # Set up environment to be used during the build process BUILD_ENV= env S9FES_LIBRARY_PATH=.:lib:ext:contrib default: s9 s9.image s9.1.gz s9.1.txt lib/syntax-rules.scm \ lib/matcher.scm all: default s9e s9e: s9e-core.image s9: s9.o s9.h $(EXTRA_OBJS) $(CC) -o s9 $(LDFLAGS) s9.o $(EXTRA_OBJS) $(EXTRA_LIBS) s9.o: s9.c s9-real.c s9.h $(CC) -o s9.o $(CFLAGS) $(DEFS) -c s9.c s9.image: s9 s9.scm s9-real.scm ext/unix.scm ext/curses.scm config.scm $(BUILD_ENV) ./s9 -i - -n $(EXTRA_SCM) -l config.scm -d s9.image s9.1.gz: s9.1 sed -e "s,@LIBDIR@,$(LIBDIR)," s9.1.gz unix.o: ext/unix.c s9.h $(CC) $(CFLAGS) $(DEFS) -I . -o unix.o -c ext/unix.c curses.o: ext/curses.c s9.h $(CC) $(CFLAGS) $(DEFS) -I . -o curses.o -c ext/curses.c s9e-core.image: s9 s9.scm s9-real.scm ext/unix.scm ext/curses.scm \ contrib/s9e.scm $(BUILD_ENV) ./s9 -i - -n -l ext/unix.scm -l ext/curses.scm \ -l ext/parse-optionsb.scm -l contrib/s9e.scm \ -d s9e-core.image lint: gcc -g -Wall -ansi -pedantic s9.c && rm a.out test: s9 test.image $(BUILD_ENV) ./s9 -i test -f util/test.scm libtest: s9 test.image $(BUILD_ENV) sh util/libtest.sh systest: s9 test.image $(BUILD_ENV) ./s9 -i test -f util/systest.scm srtest: s9 test.image $(BUILD_ENV) ./s9 -i test -f util/srtest.scm realtest: s9 test.image $(BUILD_ENV) ./s9 -i test -f util/realtest.scm test.image: s9 s9.scm s9-real.scm $(BUILD_ENV) ./s9 -i - -n $(EXTRA_SCM) -d test.image tests: test realtest srtest libtest systest install: install-s9 install-util install-all: install-s9 install-util install-s9e install-progs # old version of install(1) may need -c #C=-c install-s9: s9 s9.scm s9.image s9.1.gz install -d -m 0755 $(BINDIR) install -d -m 0755 $(LIBDIR) install -d -m 0755 $(LIBDIR)/help install -d -m 0755 $(MANDIR) install $C -m 0755 s9 $(BINDIR) strip $(BINDIR)/s9 install $C -m 0644 s9.scm $(LIBDIR) install $C -m 0644 s9.image $(LIBDIR) install $C -m 0644 lib/* $(LIBDIR) install $C -m 0644 ext/*.scm $(LIBDIR) install $C -m 0644 contrib/* $(LIBDIR) install $C -m 0644 s9.1.gz $(MANDIR) install $C -m 0644 help/* $(LIBDIR)/help install $C -m 0755 util/make-help-links $(LIBDIR) (cd $(LIBDIR) && ./make-help-links && rm make-help-links) install-util: sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/s9help sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/s9resolve sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/scm2html sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/scmpp -chmod +x $(BINDIR)/s9help \ $(BINDIR)/s9resolve \ $(BINDIR)/scm2html \ $(BINDIR)/scmpp install-s9e: s9e-core.image ln -fs $(BINDIR)/s9 $(BINDIR)/s9e-core install $C -m 0644 s9e-core.image $(LIBDIR) sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/s9e -chmod +x $(BINDIR)/s9e install-progs: sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/advgen sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/c2html sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/cols sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/dupes sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/edoc sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/htmlify sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/s9hts sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/soccat -chmod +x $(BINDIR)/advgen \ $(BINDIR)/c2html \ $(BINDIR)/cols \ $(BINDIR)/dupes \ $(BINDIR)/edoc \ $(BINDIR)/htmlify \ $(BINDIR)/s9hts \ $(BINDIR)/soccat deinstall: deinstall-s9 deinstall-util deinstall-all: deinstall-s9 deinstall-util deinstall-s9e deinstall-progs deinstall-s9: rm -f $(LIBDIR)/help/* && rmdir $(LIBDIR)/help rm -f $(LIBDIR)/* && rmdir $(LIBDIR) rm -f $(BINDIR)/s9 -rmdir $(BINDIR) -rmdir $(MANDIR) deinstall-util: rm -f $(BINDIR)/s9help \ $(BINDIR)/s9resolve \ $(BINDIR)/scm2html \ $(BINDIR)/scmpp deinstall-progs: rm -f $(BINDIR)/advgen \ $(BINDIR)/c2html \ $(BINDIR)/cols \ $(BINDIR)/dupes \ $(BINDIR)/edoc \ $(BINDIR)/htmlify \ $(BINDIR)/s9hts \ $(BINDIR)/soccat deinstall-s9e: rm -f $(BINDIR)/s9e-core \ $(LIBDIR)/s9e-core.image tabs: @find . -name \*.scm -exec grep -l " " {} \; cd: ./s9 -f util/check-descr.scm clean: rm -f s9 s9.image s9e-core.image test.image s9.1.gz *.o *.core \ CATEGORIES.html HACKING.html core s9fes.tgz __testfile__ new-version: vi edoc/s9.c.edoc CHANGES make s9.c update-library: vi util/make-docs util/make-docs vi util/make-help-links \ util/descriptions \ util/categories.html clear @echo "Now copy the new help pages from help-new to help" @echo "and run util/make-help-links." s9.1.txt: s9.1 cc -o rpp util/rpp.c nroff s9.1 | ./rpp -a >s9.1.txt rm -f rpp docs: lib ext contrib util/make-docs webdump: util/make-html advdump: prog/advgen.scm prog/adventure.adv prog/adventure.intro sed -e 's/@dir/quest/' -e 's/@file/index/g' pagehead prog/advgen.scm -rv \ -P terminal:session \ -p pagehead \ -e util/pagetail \ -i prog/adventure.intro \ -t "The Quest for S9fES" \ -y s9.css \ prog/adventure.adv rm -f pagehead cp MASCOT.png advdump sed -e 's/^A:link/A/' -e '/^A:visited/,+3d' \ advdump/s9.css csums: txsum -u <_checksums >_checksums.new mv _checksums.new _checksums mksums: clean find . -type f | grep -v _checksums | txsum -m >_checksums stripped-arc: clean s9.1.txt mv Makefile Makefile.ORIG s9/README000644 001751 001751 00000020130 12245357704 011706 0ustar00nmhnmh000000 000000 Scheme 9 from Empty Space A Portable Scheme Interpreter with a Unix Interface By Nils M Holm, 2007-2013 S9fES is a mature, portable, and comprehensible public-domain interpreter for R4RS Scheme offering - decimal-based real number arithmetics; - support for low-level Unix programming; - cursor addressing with Curses; - basic networking procedures; - loads of useful library functions; - an experimental Scheme-centric full-screen editor. It is written in ANSI C (C89) and Scheme and it runs in many popular environments, including *BSD, Linux, Plan 9, and the unmentionable horror (although the Plan 9 and Horror versions probably exclude most of the above goodies). The S9fES code strives to be simple and comprehensible. It is particularly interesting to people who want to (a) write Unix programs in a high-level language (b) try Scheme without having to jump through too many hoops (c) study the implementation of Scheme (in a language other than Scheme). There is a book describing the implementation in detail. It is available in print and PDF format. See http://t3x.org/s9book/ S9fES supports the following SRFI's: - SRFI-0: feature-based conditional expansion (subset) - SRFI-2: AND-LET* (subset) - SRFI-22: running Scheme scripts on Unix - SRFI-23: error reporting mechanism - SRFI-30: nested multi-line comments - VECTOR-COPY and VECTOR-APPEND from SRFI-43 ***** NOTE ***************************************************** If you are planning to use image files (which the S9 default setup does!), you will have to disable both address space layout randomization (ASLR) and position-independent code (PIE) for the S9 executable. This is because the image file contains pointers to functions in the interpreter executable, and either of the above techniques will invalidate these pointers, resulting in fatal "wrong interpreter" errors when the S9 system starts up. **************************************************************** QUICK START You can run the interpreter in its build directory without installing it. Just type "cc -Dunix -o s9 s9.c" and then "./s9". The S9 code is only loosely coupled to its Makefile, so in most cases running "cc -Dunix -o s9 s9.c" or "8c -Dplan9 -o s9 s9.c" will compile the interpreter just fine. (However, doing so will not include the RealNum/Unix/Curses/Networking extensions.) On most systems of the Unix family (plus CygWin and MINGW), you can compile and install S9fES by running "make install". Once installed, typing "s9" will start the interpreter. ,h explains the online help system. ,a returns a list of all help topics (long!). If the above commands do not work, try ,l contrib/help.scm first. COMPILING AND INSTALLING Unix To compile S9fES, run "make test" (this will also run the test suite to make sure that the interpreter works properly). Running "make tests" will run even more tests. On 64-bit systems, you may want to add the -DBITS_PER_WORD_64 define to the Makefile. Not doing so will probably still work, but result in slightly worse bignum performance. You can install S9fES (including the goodies) on a Unix system by typing "make install" as root, but before doing so, please edit at least the PREFIX variable at the beginning of Makefile. (Be sure to re-compile S9fES (make clean; make) after changing PREFIX, because it is used to set up some internal paths). Plan 9 To compile S9fES on Plan 9 from Bell Labs, just type "mk", but note that the Plan 9 port is rather experimental at this stage. Above all, there is currently no installation procedure. Manual Installation To install S9fES manually, - Compile s9 with a proper default library path (the one hardwired in "s9.h" is probably not what you want). E.g.: cc -o s9 -DDEFAULT_LIBRARY_PATH="\"your-path\"" s9.c A reasonable value for "your-path" would be, for example: ".:~/s9fes:/usr/local/share/s9fes" Security-sensitive people may consider removing the dot. - Copy the "s9" binary to a location where it can be executed (e.g. /usr/local/bin). - Copy the file "s9.scm" to a publicly readable directory (default: /usr/local/share/s9fes). This directory will be referred to as LIBDIR in the following instructions. Note that this directory must be contained in DEFAULT_LIBRARY_PATH, as defined above. - Compile a heap image and copy it to LIBDIR: s9 -d s9.image The image file must have the same base name as the interpreter or it will not be loaded. An image loads significantly faster than source code. Optionally: - Copy the content of the "lib" directory to LIBDIR. This directory contains lots of useful Scheme functions. - Copy the content of the "contrib" directory to LIBDIR. These files contain additional Scheme functions contributed by other authors or imported from various sources. - Create a subdirectory named "help" in LIBDIR and copy the content of the "help" directory to LIBDIR/help. These files are part of the interactive help system. - Copy the nroff(1) source code of the manual page "s9.1" to section 1 of your online manual (e.g. /usr/local/man/man1). In case you are not running Unix, there is a pre-formatted copy in the file "s9.1.txt". CONFIGURATION You may create the S9FES_LIBRARY_PATH environment variable and make it point to LIBDIR as well as other directories that contain Scheme programs. The variable may contain a single directory or a colon-separated list of directories that will be searched in sequence for image files, library files, and help pages (in "help" subdirectories of the given paths). S9FES_LIBRARY_PATH overrides DEFAULT_LIBRARY_PATH, so all directories listed in the latter should also be present in the former. If you set up an rc file in your home directory ($HOME/.s9fes/rc), this file will be LOADed before entering the REPL. It will never be loaded when running programs non-interactively (with the -f option). To create an image file containing additional functionality, add the desired options to the "config.scm" file and run s9 -n -l config.scm -d s9.image GETTING STARTED Typing "s9" will drop you into the read-eval-print loop of the interpreter. You can run Scheme programs non-interactively by typing "s9 -f program.scm" at your shell prompt. If you installed the extension library functions in LIBDIR, they can be loaded by the LOAD-FROM-LIBRARY procedure or the ",l" (comma ell) meta command: > ,l draw-tree ; loading from /usr/local/share/s9fes/draw-tree.scm > (draw-tree '(a b c)) [o|o]---[o|o]---[o|/] | | | a b c > _ Feel free to explore them. Running "s9help topic" on the shell prompt will print the S9fES online help page about the given topic. EXTENDED INTERPRETER If compiled in, there are some extension procedures providing access to some Unix system calls, some networking procedures, and a Curses interface. To compile these extensions, uncomment the three EXTRA_ lines in the Makefile. (In fact, the Unix extensions are compiled in by default.) SCHEME EDITOR The Scheme 9 Editor is started with the "s9e" command. The help page is loaded by pressing [control]+[L] and then [h]. See the "Usage" section at the end of the help file for instructions. The most interesting feature of S9E is probably its interaction buffer. Type [^Z][s] to open an interaction buffer, type any Scheme expression, move to its closing paren and press [^J]. To compile an S9E image, run "make s9e" or "make all". To install S9E, run "make install-all". To try the editor without installing, create an image (make s9e) and then run ./s9 -i s9e-core prog/s9e1.scm Note that S9E is experimental at this point. Bug reports and patches are welcome! ACKNOWLEDGEMENTS I would like to thank the following people and organisations for patches, bug reports, suggestions, hardware, access to hardware, etc: Bakul Shah, Barak Pearlmutter, Blake McBride, Bsamograd (reddit), Dig1 (reddit), Dirk Lutzebaeck, Doug Currie, Mario Deilmann, Masaru KIMURA, Torsten Leibold, and the Super Dimension Fortress (SDF.ORG). CONTACT Nils M Holm < n m h @ t 3 x . o r g > s9/Todo000644 001751 001751 00000000317 12076277277 011673 0ustar00nmhnmh000000 000000 - S9E: - [^L][!] (shell) command. - macro tests - EDOC: handle white space in block comments properly ! LETREC + double CALL/CC Petrofsky test fails (OK, this is to be expected.) s9/_checksums000644 001751 001751 00000070425 12245412560 013101 0ustar00nmhnmh000000 000000 38519FE9C4297EE3 008C 00EC ./CHANGES D9417E3BD625973C 0003 0057 ./LICENSE 63B487D4B08FED34 0012 0060 ./Makefile CC422B628E52D837 0011 0058 ./README 4AA71D05B908EEFC 0001 00CF ./Todo 3D13B5B1A44697F4 004C 0144 ./contrib/format.scm 8AA8DAD6D888BEE4 0015 01E5 ./contrib/format.txt 5C5C9843E47C67EA 0013 0000 ./contrib/format-test.scm 378F6988C15753F4 0011 01D0 ./contrib/prolog.scm BB47B20CDC78E8A4 002B 0088 ./contrib/pretty-print.scm 262163A2BCA9D29F 0005 0099 ./contrib/string-locate.scm 9B179FBB5298F02E 0009 00C9 ./contrib/help.scm 27EC86E5434DA3BD 000A 0071 ./contrib/draw-tree.scm A8739E19FCC1BE1B 0003 0047 ./contrib/prolog-test.scm 5A40481A147DD4D6 0004 00E1 ./contrib/zebra.scm F9D70683EC7F5569 0024 013D ./contrib/s9sos.scm 0C0B110F3FD0D01A 003A 001C ./contrib/s9sos.txt BF3CD1382DFA52AD 0030 0002 ./contrib/scm2html.scm 939A28F189674FEE 0006 01F5 ./contrib/scheme.css 5970E54FE440C3AD 001F 01F5 ./contrib/c2html.scm 0F6A27727E0E8FD2 0002 0004 ./contrib/ccode.css 6BE6C7DFB6D14040 0011 0055 ./contrib/S9Book CD26C7DFB6D58530 0011 0055 ./contrib/S9Book-bw F2EB9D931E12289B 0023 00E0 ./contrib/s9e.help 71A715045D564A6A 00A7 0118 ./contrib/s9e.scm 83396F4181A5F5AB 0003 0083 ./contrib/queens.scm 1BCB4C7F63C387AD 0001 0156 ./contrib/s9e-config 9F23CAB09872C33C 003B 019D ./ext/unix.c 2A0EBB71E68FD532 0001 01AE ./ext/leap-yearp.scm 12B4532984963E11 0004 019D ./ext/spawn-command.scm 507E70432D874B20 001C 0052 ./ext/unix.scm 804B735AB4F5EAF7 0003 000A ./ext/proper-timep.scm 97EDA25A054181D1 0002 017B ./ext/basename.scm 001C83C0F97DD612 0005 003D ./ext/unix-time-to-time.scm FC47E26A5DD297D6 0004 0097 ./ext/time-to-unix-time.scm 7D16654AC1A21B95 0003 0168 ./ext/dirname.scm 1446A61E676DDC6B 000A 00A6 ./ext/format-time.scm 76A0F8AE20E4E0F2 0002 011D ./ext/append-to-output-file.scm 6EFEC094EAFDF1A6 0013 00B7 ./ext/parse-optionsb.scm 4AAC9925C11CC582 0002 01EC ./ext/search-path.scm 32BC6595907DB8B7 0002 012D ./ext/unix-tools.scm 6A9EBC4763D13CFD 0009 000A ./ext/find-help.scm ADC81E8B344A7F4F 0003 0144 ./ext/mode-to-string.scm B952BD936778AC9E 0002 0038 ./ext/flush-output-port.scm DCC24ACFAC0EABA5 0004 007A ./ext/standard-error.scm 6DA73BB6DBB0BA9D 001A 00CC ./ext/curses.c 45BE0218588DEDA7 0005 000C ./ext/curses.scm D55CBB23369B7678 0008 01E6 ./ext/inet-server.scm 29B96A5038624A93 0004 015D ./ext/spawn-shell-command.scm 7CFF9251BED5689C 0002 00BA ./ext/find-help-path.scm 790B1C84248F5ABF 0005 01C0 ./ext/time.scm B52A7853D8AA657B 000F 0196 ./ext/runtime-stats.scm 2FCAF836A050D73C 0006 00EE ./ext/time-ops.scm 5458F4E985BFEE4B 000B 01FA ./ext/get-line.scm 55082A52BB6D9DE2 0001 0168 ./lib/count.scm 375CC3D555F84C42 0001 0128 ./lib/depth.scm 464810BFA8D310D9 0002 007B ./lib/filter.scm 51CA0B3A0E9820AF 0001 01EA ./lib/flatten.scm B7144B39FECE0C8F 0003 004E ./lib/iota.scm AC0E8CEE120DF01C 0002 00BB ./lib/mergesort.scm 09F287CD0376B053 0002 01DD ./lib/partition.scm 58EC313DE0E7D506 0002 0106 ./lib/quicksort.scm 2F359F4040A157FE 0003 00FD ./lib/remove.scm 9080CD0DA8D595B6 0002 0021 ./lib/replace.scm 60832C911AC3A357 0002 0025 ./lib/substitute.scm 249A53C841239C45 0002 017A ./lib/read-line.scm C88E876C3718189D 0001 0178 ./lib/explode.scm 1F38532402B951AB 0002 0029 ./lib/implode.scm CF82EA38BD06A4D2 0003 0038 ./lib/exists.scm A292AB8B3F868C28 0004 003B ./lib/factor.scm A475D50E57190413 0002 0042 ./lib/factorial.scm 0342AB158DBFCAF5 0003 0123 ./lib/for-all.scm BDD3D8442AF39C6A 0002 0010 ./lib/hyper.scm D8645342FEBAA10A 0001 0152 ./lib/sum.scm 101734E4FF1E0267 0002 00E4 ./lib/integer-sqrt.scm E0665D4C48683C88 0003 018D ./lib/combine.scm 472A3468919AA7EB 0006 01F0 ./lib/hof.scm 6922FC75E4A3D779 0003 00BA ./lib/make-partitions.scm B24E69E624097C71 0002 007A ./lib/list-to-set.scm C854E53C5B41954A 0002 00C1 ./lib/intersection.scm 949B7AC052DDC5AA 0001 016D ./lib/transpose.scm DE46D37A03B69BD0 0001 0150 ./lib/union.scm B8DED308527E81E7 001D 01A0 ./lib/regex.scm D7373522F8825FA2 0003 0047 ./lib/string-split.scm F5C1A90F981678EF 0015 0027 ./lib/read-from-string.scm 621EE834D98217BB 0008 00E5 ./lib/write-to-string.scm 151C982818F61DEC 000C 004A ./lib/package.scm AF42CAF99BF3B0A5 0010 015A ./lib/amk.scm 1681555F50966680 000C 0191 ./lib/symbols.scm 9058CAE450167641 000E 00F2 ./lib/records.scm 54A03C5D2CD3A3BF 0003 00F2 ./lib/cond-expand.scm 1E74C6735EF8FB32 0005 010F ./lib/letrecstar.scm DE37609564927226 000C 0143 ./lib/programp.scm 3669199FD1F6EE7A 0005 00B6 ./lib/fluid-let.scm A07A9C63405707A6 0002 0128 ./lib/read-file.scm 2934BB0547E1B545 000B 0196 ./lib/bitwise-ops.scm D5DAE46FEE908310 0003 00AE ./lib/fluid-let-sr.scm F568C5FD39424B2B 0005 0041 ./lib/keyword-value.scm 476B9ADB62E870AA 0013 0015 ./lib/matcher.scm FB8B2B3035E0886B 0002 00D5 ./lib/string-case.scm 620A30B4E0C0DDA6 0002 0176 ./lib/unsort.scm B2856A53C415EE78 0003 01C2 ./lib/string-parse.scm 4881F4166E56561D 0002 00C5 ./lib/string-unsplit.scm 3AA339944668D664 0002 011F ./lib/sieve.scm 3668C2F89C7E0BE6 0002 0155 ./lib/displaystar.scm A4FB74BB5F8127BD 0003 000E ./lib/list-tools.scm 99927DA8039D4E00 0002 0085 ./lib/syntax-extensions.scm 9B6A1D528AEF1325 0002 001A ./lib/math-tools.scm 87217C4B50B52E10 0002 002D ./lib/set-tools.scm 4155292745888606 0001 0180 ./lib/io-tools.scm 79E7204F71A04814 0002 014A ./lib/string-tools.scm 1CCE2092BD65E771 000C 0109 ./lib/streams.scm E6899A7217E2814A 0004 0064 ./lib/string-find.scm 1B587B85D58AC845 0003 007F ./lib/string-translate.scm 4AD4E8E26BCF2A3C 0003 007A ./lib/string-digest.scm 2FE3B73F32006978 0004 0111 ./lib/string-find-last.scm 4D3E4114BE66FA93 0006 0117 ./lib/name-to-file-name.scm E7FA470A5C642025 0005 00E0 ./lib/and-letstar.scm A434AF23C132273A 0011 0028 ./lib/syntax-rules.scm E2B518332B57CB01 0005 01BD ./lib/string-position.scm 49B299EEB9014474 0006 004C ./lib/string-last-position.scm 8B94F0939E838778 0008 0145 ./lib/split-url.scm C9EF9B7AC43679DE 0004 00A2 ./lib/url-decode.scm 091E604BA41429F9 0009 0039 ./lib/tagbody.scm EFEE002E6095CA15 0004 0096 ./lib/vector-map.scm 1C5EB8A315FE2FCC 0002 0123 ./lib/string-scan.scm 8C0EAA3A08A23CDE 0001 0178 ./lib/sort.scm 8C34ECB20E918CE5 0002 01E7 ./lib/string-map.scm 44872FDB0065FC2C 0002 00E2 ./lib/sublist.scm FC0434DA613FDF5A 0002 006E ./lib/subvector.scm 9D1DD8A0AE8B1A9F 0001 00E8 ./lib/vector-tools.scm 1CF5805266006B22 0002 009F ./lib/letcc.scm 1C54590DA9C0B16C 0004 00F1 ./lib/threads.scm 2A314FD35AFAF961 0004 0040 ./lib/catch.scm F9F56F38184226F1 0011 003D ./lib/array.scm 756BE7C65B4C1224 0006 01AF ./lib/amb.scm 81E343112AAE13DE 0003 0124 ./lib/position.scm A6D58788A94BF642 0002 00D5 ./lib/set-difference.scm 211D6C319F5D3AAD 0004 0142 ./lib/simple-modules.scm A86EE3FEF68844D0 0001 014C ./lib/adjoin.scm 0B9E999AC5410656 0002 0185 ./lib/subsetp.scm 91C8FC439EB729F3 0003 0130 ./lib/tree-copy.scm 3472DFA447E6363A 0002 016F ./lib/equal-cip.scm 8FF35EE518007F86 0003 01B9 ./lib/type-case.scm 590A62B44BF25C03 0001 01FC ./lib/assp.scm 86C76AF7A85AA287 0001 01E2 ./lib/memp.scm 5C194F8FB0AD2A46 000E 013F ./lib/t-sort.scm 14ADB20697EE108E 0001 0117 ./lib/graph-tools.scm A7EF4DD4F07D4529 0002 014A ./lib/tree-equalp.scm 9B0B54EFF93B2DF3 0001 017C ./lib/data-structures.scm 169FC362BAFC4483 0005 003E ./lib/permute.scm 1FA00367723C9AA5 0004 008E ./lib/random.scm 7B3A2ACD9B1B0CC9 0002 01EA ./lib/split.scm 68D101A896371D36 0003 0157 ./lib/merge.scm FC9FC1017BBD382E 0004 0104 ./lib/integer-to-binary-string.scm C4B231106E6EA67E 0002 0064 ./lib/id.scm DB5409E8CD8C3FDE 0004 01A9 ./lib/memoize.scm A4449D4C6FAD93B7 0004 00D3 ./lib/queue.scm C991735DD7036A26 0003 0154 ./lib/duplicates.scm D627A21D04DB670B 0002 01E5 ./lib/when.scm C8936007B7CF54E7 0003 0104 ./lib/while.scm 4EADB24DDCF158A3 000E 00CF ./lib/hash-table.scm 54F2EE08C6BC5C62 0001 00F7 ./lib/_template 69963A1EC80E59EC 0002 01F4 ./lib/tree-map.scm A4A24646B27FD6D7 000D 0059 ./lib/char-canvas.scm 92F137470D6C80D6 0002 002D ./lib/listq.scm 84FE6DE8DE6AD4AD 0003 00B9 ./lib/appendb.scm 166F3D9E2FC0F05A 0002 00A6 ./lib/random-sort.scm BC837099EC5C9D64 0002 0151 ./lib/string-reverse.scm 32DD10A8FE1A0358 000F 01D2 ./lib/rb-tree.scm D832C8E487554174 0001 01CB ./lib/list-copy.scm 887D22CBF80E653D 0006 0180 ./lib/setters.scm EB23197923131A07 0002 00AF ./lib/htmlify-char.scm 4022E03ACDB67F1A 0003 0112 ./lib/loutify-char.scm 092D5D5B420D2B24 0003 0088 ./lib/string-expand.scm 90947352CA93391B 0007 004A ./lib/bitops.scm 2F55AC518550DD80 0002 00E2 ./lib/string-prefixeqp.scm 1405E423580E4621 0005 01C0 ./lib/get-prop.scm 3F012D77821B9743 000E 00DE ./lib/define-structure.scm 0A0F4486B14BECD7 0002 0127 ./lib/group.scm CC38B0B085124128 0002 00D7 ./lib/take.scm ABC8E61499CC5122 0002 008D ./lib/choose.scm BED403AA053F23CC 0008 004F ./lib/char-plot.scm E8239ACC6FF06797 0003 0003 ./lib/collect.scm 77401F10FF8489E0 00E2 0065 ./s9.c 268BBEB769AA932C 0001 00A1 ./mkfile E5C3AFB333C67FCE 001F 01EC ./s9.1 E1732E033D0A3AA7 0022 0001 ./s9-real.c FCB7B80F5228950B 001A 0066 ./s9.h 4F3144D68686E09A 000C 008C ./util/rpp.c 46E388DA334DE03F 0001 00BA ./util/rp_html 49DAF738AC72AD07 007D 015B ./util/test.scm 681BB2A956E28007 0039 0035 ./util/libtest.scm 4D1E4254E01E02DF 0003 01D4 ./util/libtest.sh 2100DB65718ACD92 0001 0145 ./util/dirhead 04000A194E995E94 0013 013E ./util/descriptions 8469A9689C73E578 0001 0045 ./util/dirtail 374FAFB4A32B0D73 0007 00FB ./util/srtest.scm F25D9DBA0BAEDD56 0011 008C ./util/make-html 25E39FFACEA37D58 0004 00A6 ./util/s9.css 9075AF153CA942A7 0004 00AA ./util/make-docs 8C9D2B5BF9A28792 0001 0146 ./util/libhead 8469A9689C73E578 0001 0045 ./util/libtail 37F03EEF92CF7BDB 0018 00BB ./util/make-help-links 66768FFC85FC5CDE 0008 0136 ./util/stress-tests.tgz 838FB5B0D92AF447 0022 01C1 ./util/systest.scm 010F2AB76061134F 0003 00E5 ./util/check-descr.scm 9D467ADBF439C3DB 000F 0091 ./util/categories.html 921E23C8B0BB59F3 0005 0137 ./util/make-cats.scm 2ED0434E34498AB3 005B 00E5 ./util/realtest.scm 05E9A9689C73DBA4 0001 0035 ./util/pagetail 840D61984B29A271 0001 0088 ./util/pagehead 627B4D96BC9A4C5D 0025 001C ./s9.1.txt DEC4353681FA1518 0002 008E ./config.scm 1BB33C11D940F9F3 0004 00E4 ./prog/c2html1.scm EFF07203A73202D4 0012 001C ./prog/s9resolve.scm E96D49A03A66D5D3 0006 0009 ./prog/soccat.scm DE050A1064F20FF9 0005 00A6 ./prog/htmlify.scm 5830F925DC7EE390 0006 00E0 ./prog/dupes.scm CD78F63B3C1BDBB9 0005 015A ./prog/s9help.scm D3D710F10E806743 0006 01CD ./prog/scm2html1.scm 9BC1C2353B6871A1 0026 01C4 ./prog/advgen.txt 472E4403D2DDC92A 002E 01C4 ./prog/advgen.scm F2F28A671CA13DE7 0002 0074 ./prog/adventure.intro C3DF6C5773FDDAA3 0003 000D ./prog/s9e1.scm 33D3B8984B5868C9 0004 0115 ./prog/scmpp.scm 06AEA8D1839BEE0D 0030 00B9 ./prog/adventure.adv C3279934AD948150 0012 00D6 ./prog/s9hts.scm DCED81EE1DB42DF8 0005 0143 ./prog/cols.scm 4C1B0D1697BFA3E4 0043 00AC ./prog/edoc.scm C2AA298E0E881F4F 0002 0180 ./prog/edoc.css 913C3822CCC25542 0005 0046 ./prog/s9symbols.scm CAF8EF1BD80C0E89 0002 01F9 ./ABOUT 36F457066256077C 0002 0075 ./freebsd-port/Makefile 19DA139BB4C31CE8 0001 0088 ./freebsd-port/distinfo C9BA6F5F5400A140 0001 013E ./freebsd-port/pkg-descr 57C6D42D23479AB3 0032 0156 ./freebsd-port/pkg-plist A5F1AB3F6B922F16 002B 0000 ./s9.scm 41280F502B584336 0022 01B9 ./s9-real.scm E3AC1BF4412CBEE6 0003 005D ./help/help 661324FFC5F99F37 0001 010C ./help/not 53F34BBE02762149 000A 0146 ./help/eqvp E1C076DC0ED20B52 0001 00A1 ./help/delete-file FCC4F26DB41D498E 0001 00BF ./help/booleanp 0A0201187FF17E63 0004 006B ./help/eqp 866329B191D7C535 0002 00A2 ./help/equalp A99BE705C3286E20 0001 00D1 ./help/pairp 87541D69B0DD9264 0001 018B ./help/cons 1C0287BACD349661 0001 0101 ./help/car 43345406369E0511 0001 00EA ./help/cdr 7B892CC73268D91D 0001 0113 ./help/set-carb DD092CC73E6EE51D 0001 0113 ./help/set-cdrb 49144AF7400A2BEB 0001 0195 ./help/caar 47F6BB6F96DF82C5 0001 0066 ./help/nullp 30D874F7C963DBB3 0001 014F ./help/listp 2E1C1644DC4271CC 0001 009B ./help/list F80040835202DBC4 0002 006D ./help/append 0FA13318EDBCE560 0001 00AA ./help/length BD006A4AD45AD987 0001 00E0 ./help/reverse D4DA59D76927DF0C 0001 00EF ./help/list-tail 339C3DF15A0902E7 0001 00B1 ./help/list-ref FE52C2EE12ED1A6B 0002 012E ./help/memq BB59F534C038455F 0003 0046 ./help/assq F13B1FDC05220069 0001 0123 ./help/symbolp 5C006B86A416387A 0002 01E9 ./help/symbol-to-string FFD712951E986CA0 0002 0182 ./help/string-to-symbol D3AC55056D6013FB 0002 0120 ./help/numberp 5D9A13EF11D96E2D 0002 014A ./help/eq 8F7DFB75600607B7 0001 0161 ./help/zerop F89E61506D3BCCCA 0001 0124 ./help/max 7FCA8AA9ED919399 0001 0135 ./help/plus 29A3A61FA824CE1B 0002 0054 ./help/letstar A3DBB9B49FF6571E 0001 0194 ./help/minus CD0876DF8D09544F 0001 0064 ./help/abs ED21DFF355609178 0002 01F7 ./help/quotient E1374C1BC5EF42F5 0001 0134 ./help/gcd 5E8C72263E4A9F6B 0001 0087 ./help/expt 83648BDD3C38CACE 0002 01F0 ./help/number-to-string 396A86F978E2691F 0002 018C ./help/string-to-number 47F6AD7265F72B2F 0001 0063 ./help/charp 0F4E2B5890E28201 0002 01AB ./help/chareqp 15BBCEF2F110A02D 0002 0064 ./help/char-cieqp 1FDAAECAFF73A521 0001 0062 ./help/stringp 69F44FE30855E2D6 0002 00C1 ./help/char-alphabeticp 05E253858FA57298 0002 00D4 ./help/char-to-integer 016FD40CB81A3054 0001 012C ./help/char-upcase AEBD88BC372813FE 0001 0126 ./help/make-string CFCAC4F83631B677 0001 0066 ./help/string C0AD0942F6BD5441 0001 0066 ./help/string-length FD9414A50CCB235E 0001 00B9 ./help/string-ref D18BB104FAF24DA7 0001 01C4 ./help/string-setb D08DE76A98C1659C 0001 0185 ./help/stringeqp 56D1F61BB024A0EB 0003 002E ./help/stringltp 0274ECDB7A14247E 0001 0162 ./help/substring CD69082199FD61FB 0001 0092 ./help/string-append 9BCDEA940934D9B0 0001 015C ./help/string-to-list 7E55751E754984D2 0001 0061 ./help/string-copy 9A8DC0DD636CB104 0001 008A ./help/string-fillb 1FDAAECAFF8AE441 0001 0062 ./help/vectorp 84BAFE6797269F02 0001 0126 ./help/make-vector 6295BD6EC2CEAFF0 0001 00AE ./help/vector C0ACF3D1A98DAE41 0001 005A ./help/vector-length 2D6029ED924988EB 0001 00DF ./help/vector-ref 2A90618E8E3EF811 0001 01CB ./help/vector-setb E44F03CA249D95DA 0001 0181 ./help/vector-to-list 2F3311B2773B7DD4 0001 0096 ./help/vector-fillb 3BD901B13E228404 0001 0119 ./help/procedurep 9C5A49E678C30A79 0001 01FD ./help/apply 4C38382F79D2F47F 0002 0108 ./help/map B48E9CE8B19828EB 0002 002E ./help/for-each D63037A83320D3A6 0006 01EF ./help/force 4AFECBCD0C045854 0002 0145 ./help/call-with-input-file 75B09654770C391F 0001 00B8 ./help/input-portp B0A15F7083ACAE07 0001 0098 ./help/current-input-port 8CE2893D00081790 0002 00DB ./help/with-input-from-file 42DF7984B2DAF995 0001 00DE ./help/open-input-file 9CCEC5921C6EAAD9 0001 0140 ./help/open-output-file FCBA96E241A61162 0001 016C ./help/close-input-port B196B16E16B7FE18 0003 0032 ./help/read DDD237E8BE024F43 0001 0194 ./help/read-char B6B79654EBBC2659 0002 014C ./help/peek-char 41D6770B764EDF8A 0001 011B ./help/eof-objectp 5C066F7CCA56A1F6 0001 01F1 ./help/write 64A042674D75FA8E 0002 0138 ./help/display 0E99C808CDA36E76 0001 0165 ./help/newline 2F75DAB51423748B 0001 016A ./help/write-char CEA7F4A94912B97A 0002 0044 ./help/load ACE80EF36232CAF5 0001 0082 ./help/file-existsp 928D26B4886D0A0F 0002 019A ./help/fold-left 5E6019B99FE8B951 0002 01A8 ./help/fold-right AC25ACFCD1C97AD1 0001 01BC ./help/gensym 5561784AD1AC096A 0001 016F ./help/load-from-library D4434A5A4849D237 0002 01F9 ./help/locate-file 5BB42AE88C65C33F 0001 0158 ./help/print 1E5144F364D286AD 0001 00F5 ./help/set-input-portb 14DCA205B0FB881D 0001 004F ./help/symbols 92955140AFBD5155 0002 0025 ./help/begin 2E566C19D7CA9B1D 0003 014C ./help/case 2A7DA465FA499B69 0004 0070 ./help/cond 1486E5A007D84F58 0006 0112 ./help/define 8C18B242EE75D67F 0004 0196 ./help/do E5F3B7EDA5D74209 0002 00BD ./help/if 6C62D63217818CCA 0005 00EA ./help/lambda 1E0DB429A28DF3B9 0004 00D2 ./help/let 518F148E60D12E68 0005 0190 ./help/quasiquote AF591D82EA15994A 0003 01C4 ./help/letrec 2846CA666A47A766 0002 002E ./help/or E0AF2430F6EDDC50 0001 01F5 ./help/and 3C6F5F506931F96C 0003 003F ./help/quote 7F1B8989D96DBE7B 0001 018F ./help/setb D958B8FEF861CE97 0003 00B9 ./help/starstar 9C06A1E04F7CC22F 0005 0039 ./help/define-syntax 745AE184C88937B6 0008 0129 ./help/syntax-rules B42C64CC81968150 0007 0109 ./help/bitwise-and 2D7F257E06126EC9 0005 0002 ./help/complement 54D562EEECF3764C 0002 0038 ./help/cond-expand 2A3958BBA59E0809 0001 0068 ./help/count 241FB7D7FE02D7E2 0001 0065 ./help/depth EA0BD37F31399C23 0002 0023 ./help/draw-tree 79274018D3FAF477 0002 0031 ./help/exists C5FADB0B1C643C78 0001 008F ./help/explode B1C866ACE3A22CC1 0001 00AE ./help/factor A6ACBEB145E4718B 0001 0086 ./help/factorial 9C1882794E0EB6A1 0001 00E5 ./help/filter 1E8F23CDE9EFAAB1 0001 0070 ./help/flatten C3997D1846A4ADAC 0002 0062 ./help/fluid-let 455A31843367BB2C 0002 00AE ./help/for-all 7A4563450B2EADC4 0016 000D ./help/format 714AA761FEF3E65F 0001 00A1 ./help/hyper DC580E2147174751 0001 008F ./help/implode A8CDACFBB36871F8 0001 00A0 ./help/integer-sqrt FBCF0F5CE928E18C 0001 008F ./help/intersection F65E2B694A82820A 0002 0090 ./help/iota ECBF24F76381ECE4 0001 00BC ./help/list-to-set E66C43D9A399015C 0005 013A ./help/make-hash-table 49F7822FA2DDFE9C 0001 0132 ./help/make-partitions F20A42684718B288 0001 00F0 ./help/mergesort 218BD3FBB8EAA63E 0003 010C ./help/make-rbt BF9409EC88610C38 0002 008B ./help/module 0BB815ED4BA77DB4 0001 01B0 ./help/partition D93A96398513C2EB 0005 00BF ./help/pretty-print 83D102D4D8E241AD 0001 0102 ./help/programp 10CA8B8F1094B9F3 0005 0090 ./help/record 5DDE64070A618856 0004 002C ./help/prolog 0B62532314BCF04C 0001 0069 ./help/sum A79C26476D12163C 0001 00EC ./help/quicksort 840154967DB20B27 0008 0089 ./help/re-comp EA8E3D2A23A3D35C 0001 013D ./help/read-file BD0BE9F11BE74A67 0003 015D ./help/read-from-string 523B1244EA20929B 0001 0124 ./help/read-line EF41CA6D8191865B 0002 0069 ./help/remove 9D81B54122E38363 0001 00D9 ./help/replace 4692AC1B02C878D6 0002 006D ./help/runstar 8E5488E9AD91C6BE 0001 00EE ./help/mode-to-string 9E99EF2D701CBBF3 0003 0034 ./help/string-find B37AD5C68D27CF06 0001 0167 ./help/string-split 228CEDE182C718B2 0001 0082 ./help/union 4DAB29EAD1E9BD65 0001 0105 ./help/substitute E1C0B565155F24BD 0001 00CE ./help/transpose E5A1A71B3E24D67F 0002 005C ./help/write-to-string BC000B9E3F8DD391 0001 0159 ./help/zebra 695252F45313FA22 0001 01BE ./help/string-upcase 51FF77D9F6388BB2 0005 00C9 ./help/define-matcher B80C6EC59A5AF300 0004 0014 ./help/sys_chmod 4690589DAAB2BA9F 0002 0047 ./help/sys_chown 1BF3AA7C897F650F 0001 01B6 ./help/sys_access D5D6BCE65AFAF8EC 0001 01E8 ./help/sys_dup 62D4469F6EB1582A 0001 0087 ./help/sys_chdir 71E46E57EC1D595A 0001 0158 ./help/sys_command-line FA16D1F3B8DB2C7E 0001 00E9 ./help/sys_errno 49E17F8CF5FBEACF 0001 0079 ./help/sqrt 2F30936CC619F3B3 0001 0136 ./help/string-parse D2C0E1D141374F06 0002 01C3 ./help/format-time 49F259B5E49143BC 0001 0135 ./help/sys_execv E62237738116D451 0001 0122 ./help/sys_exit 06A72210662C30D5 0001 00CA ./help/unsort B190022B897D8ECE 0001 0097 ./help/dump-image 82099D6C5E84CCC2 0001 0172 ./help/error C0B23AD62EF9AC48 0001 0083 ./help/sys_flush 3210149963B4BF38 0001 0112 ./help/sys_fork 790EE7D90A6554BE 0001 00E1 ./help/sys_usleep 669FC1D7C791C672 0002 0125 ./help/sys_user-name 61A942513D409E8A 0003 0085 ./help/letrecstar E782A08A5DD8FFFA 0001 01D8 ./help/string-digest EC8FDB20B82CE7B0 0002 00F6 ./help/sys_lseek 677F26A1CF421947 0001 0072 ./help/sys_getcwd 0734810294441500 0004 00E4 ./help/sys_open 1FE670CA632B1079 0001 00E1 ./help/sys_getenv C02C078EFF63A2F9 0001 00B2 ./help/sys_readlink BA01E37EDA7A5FAC 0001 01A2 ./help/sys_getgrnam 6F9A412E447FBE2D 0001 00A3 ./help/sys_rename B9CFA8D2CD96E823 0001 0102 ./help/sys_getpgid 8F5DBB6099C7CF26 0002 00BA ./help/sys_select C07BD3A2DD3E3480 0001 01DA ./help/search-path FCD7A0CB47CED647 0001 00AC ./help/sieve 65B5CB37B7B2948E 0001 00A7 ./help/sys_symlink 70DA01BA5EBB83F3 0001 0066 ./help/sys_getpid 6715D8AC8452AE12 0001 00AB ./help/sys_system 560AA96FF00A203F 0001 0121 ./help/sys_getpwent 6FF8D9AE3EA7560E 0002 0160 ./help/sys_umask 16F23B05BC8DBCF3 0002 0145 ./help/sys_getpwnam EDD40A694FD8BC3C 0001 00B0 ./help/sys_unlock 795FDF51F39A7A41 0001 00A9 ./help/sys_getuid 3188CC12E1A7B755 0001 00A2 ./help/sys_utimes 1594A2CB3BF0FB98 0002 00B1 ./help/sys_wait 5218AB8B869DD3D8 0002 0134 ./help/sys_inet-connect 5FC2367702F293CE 0003 01DC ./help/sys_inet-listen 89D260DC9EA6311C 0001 0110 ./help/time-to-unix-time B0F0360128842207 0001 01E3 ./help/unix-time-to-time 4AFBCCEF33668995 0003 01C5 ./help/sys_stat-name 457E2685F3E4C9AE 0002 010B ./help/sys_kill 6F02211B72EB86AC 0001 00AA ./help/sys_link 4DE1D6A43CAB018D 0001 019E ./help/sys_lock 91BE92451E36B15C 0002 0025 ./help/sys_make-input-port 83C84260D64B0198 0001 013C ./help/basename F0A2988C5FA5C9EB 0001 00CE ./help/string-unsplit 625C19BDA277F159 0002 005C ./help/dirname AD81C9A316351594 0001 00D6 ./help/proper-timep C82AB335A59C4C40 0001 00A8 ./help/leap-yearp 0E608F84E037B53D 0001 0093 ./help/sys_rmdir 55EBF2AE01EEFE27 0001 010A ./help/sys_mkdir BAEB4003169F6163 0002 0062 ./help/sys_pipe F906CC6FB5F7E502 0002 01E0 ./help/sys_read 75828B5D60345669 0001 00E7 ./help/sys_readdir 2F7FD4580DE5F80E 0001 015C ./help/sys_setuid 85506A0DCF96929E 0003 017B ./help/sys_stat 21AA7BAC84405A40 0001 009D ./help/sys_unlink 1A0EF36F442BA462 0001 016D ./help/s9e 0B704D4FA8083C42 0001 01A2 ./help/append-to-output-file F26199D4586AF6EE 0008 011F ./help/parse-optionsb 56ED9D297DDE5CFA 0002 0186 ./help/spawn-command BBE90906F78D5CC6 0001 0173 ./help/displaystar 804A04F4584DEF93 0002 0164 ./help/find-help 0BD8A7D6E28F81E3 0001 0166 ./help/sys_group-name 4043B50374DD774F 0002 0079 ./help/string-locate 78818ABB4DFD8C2C 0001 012E ./help/flush-output-port 4792DF88BC510423 0002 0135 ./help/spawn-shell-command 9216DD2EF179F4EC 0003 0098 ./help/string-find-last 502195C81D62DBEE 0001 00CA ./help/find-help-path 551A411721F45C90 0007 018B ./help/make-stream AD43B87553E65669 0003 0009 ./help/name-to-file-name 8298F02F1FFD5F12 0002 010B ./help/standard-error-port 82042165D46179DC 0001 01C2 ./help/string-translate 26933FA52BC35368 0001 014B ./help/string-scan 735FAD2F71C88F6B 0003 00AB ./help/and-letstar 0B37DB694DDC98E9 0004 0008 ./help/curs_addch 236CFD0EB2D656C2 0001 011A ./help/sys_get-magic-value 1F9E50CC94CF5EDB 0006 0021 ./help/curs_flushinp FC9C65C7893D884F 0003 01B8 ./help/curs_delch 98E11D9E2831E2E9 0003 00AB ./help/curs_attroff 580AF7C92A9FE9D3 0008 0003 ./help/curs_cbreak FC868632BC7CA693 0001 00C8 ./help/sort 926038290F0E94B4 0002 00A2 ./help/curs_clear 2D1C16DDE9934377 0002 0039 ./help/curs_cursoff 59499F1CCB70DE3D 0002 0106 ./help/curs_endwin 906E19D3055D53B4 0001 019F ./help/sys_inet-getpeername 0CAC9540B280555D 0003 0082 ./help/string-position 6A5BDC5CBA154415 0003 00E4 ./help/string-last-position DC87F9BEA3C3586F 0003 0199 ./help/split-url 61CAF566763FBDEF 0004 00C8 ./help/inet-server D2E5E78554AFB360 0003 00B9 ./help/sys_stat-regularp 71E8F4AD376AA918 0001 00EF ./help/sys_strerror 2F842389B22DE240 0002 014A ./help/sys_catch-errors 3930459BFBB90A82 0001 01BA ./help/url-decode 84D5C063C269A4C6 0001 00A4 ./help/sys_fileno 8A627DB32D4F66BF 0001 01FE ./help/r4rs-procedures 4676B57AA6D10747 000A 012A ./help/define-class A529FB6829258EB8 0002 00E0 ./help/vector-map D0E1C4C0DFDFF387 0002 0064 ./help/string-map 9A8BC954FA931CB5 0001 0128 ./help/subvector E5A0D57F52A65A88 0001 010B ./help/sublist 3DC5CF87C621F682 0008 014E ./help/call-with-current-continuation D00D9A57DAFBC082 0001 018D ./help/letslashcc FB7F8ABBEBBA4339 0002 01AC ./help/thread-create 26F211647EF2D804 0003 0057 ./help/macro-expand 3B183ECA317A27AB 0002 01D0 ./help/tagbody 840BAFDB646FE8E6 0005 00E3 ./help/define-structure CDFBC3200A7E0725 0002 0169 ./help/catch D0D59229449B6AF5 0006 01B7 ./help/make-array 2B90CC5D0B6D2058 0004 00F1 ./help/amb AF1ABC9656DF86AA 0002 013A ./help/position E5A5C1533335B20A 0001 0095 ./help/set-difference 3C2527D04DBE7039 0001 008B ./help/adjoin 346CCD20F82D5933 0001 0175 ./help/subsetp 05A59A5B6B077AC4 0001 00E6 ./help/equal-cip C582AB1EC029D4C3 0002 0098 ./help/type-case 089C9401C639A498 0001 00E3 ./help/memp 93655CC86AD6C4DD 0001 00F6 ./help/assp 786BEE84B40B2F0D 0007 00A8 ./help/t-sort 0A016D2691DB34E7 0001 01E1 ./help/tree-equalp 0E24B273D7F0E671 0002 0054 ./help/permute 7FCD8B4E1E1CC35E 0001 01FE ./help/combine B11AB7BC4ED66A8F 0002 0064 ./help/random BBC4B2EF0CA547A5 0001 01B7 ./help/split 28141200C2B6B26D 0002 00D8 ./help/merge 90E49E0381412E63 0002 01C8 ./help/integer-to-binary-string 9E044064DD6E9277 0001 019D ./help/id 670F964E22DA86BA 0003 0041 ./help/memoize EEB541D28080E25E 0002 00D1 ./help/duplicates 4F0DD956019AC9AA 0003 0086 ./help/queue F971EE7A3343FC20 0002 00EF ./help/while F8A1F431CE993068 0002 00E4 ./help/when 2DF51C4997A511C6 0002 0026 ./help/exp 23EDBB9835222649 0002 01E9 ./help/keyword-value A37062A140EC90BA 0001 01E0 ./help/reverseb 65EB237F12D967A1 0002 00DE ./help/stats 96ECF75C0549DC32 0002 0018 ./help/trace C57360FEDEB8A394 0001 003F ./help/void 5CA152AFE5E12183 0001 00C3 ./help/undefined 3ED511392BFD7FDC 0001 01FD ./help/tree-map 48018A28A957DFCA 0003 00F0 ./help/pushb 71CD6D04F427D2D7 0003 01F4 ./help/package 942DF1C95FE2B148 0001 01CC ./help/sys_gettimeofday 61F4EF936FE1D897 0002 00DA ./help/time 4275E1E61C593F9B 0005 012F ./help/runtime-stats 93F10C2BD4BE125E 0005 00B9 ./help/make-canvas 375CB8653F842935 0001 013E ./help/listq C8D809564EFA9C72 0002 0011 ./help/appendb 7E16E1264AE92CED 0001 016D ./help/random-sort 72A0CE33B08696EE 0003 0019 ./help/floor 8E569C47770B0189 0001 00E5 ./help/exactp 7C51CCD3BB4FA92E 0002 0129 ./help/exponent 10D3672E6978D6AB 0001 0184 ./help/exact-to-inexact F97EBF707A616273 0001 016E ./help/string-reverse 81AEBB71B3964EB8 0004 01C5 ./help/c2html D87687F44AA6012B 0006 01AB ./help/scm2html 5ACB0779946E8BED 0001 0192 ./help/group 34A1A9C11BC7AA5A 0002 01DA ./help/char-readyp 1FFC26939DCB6ADA 0001 0139 ./help/loutify-char 20BBC8B4FB096EC6 0001 0131 ./help/htmlify-char B69732DBF6D298C0 0001 0185 ./help/string-expand 5864BCAA8DE4E541 0004 00D9 ./help/bit-op C135A5E28A7611B3 0005 0135 ./help/bit0 0AEC7BCD50BCE1DF 0003 01A6 ./help/time-add EF9B37DC7F0670BE 0004 013B ./help/get-line BD9FB5F53EBD62DA 0001 0169 ./help/string-prefixeqp E3F7D9F2AB29D4E2 0003 0058 ./help/get-prop 545CF76FAACC67CD 0001 012C ./help/data-structures 4BF0D16CDC6929E4 0001 00AB ./help/graph-tools 4ED7F2C2170EB33A 0002 0077 ./help/syntax-extensions 760E0E68A89B0AD6 0002 0040 ./help/tree-copy 0CB1B78BCED47EB4 0001 00B9 ./help/list-copy 8A7282DB23A9CDF4 0001 015F ./help/take 25976E7D26754854 0001 014F ./help/choose F7CC53DDEC9AEC97 0003 00C9 ./help/char-plot 40078D19134214E6 0002 00D8 ./help/curs_color-set EE5ACA15C955F75A 0001 0151 ./help/vector-append 7C0C57673223CDF8 0001 00DC ./help/nase FEC0CFEFFA31F712 0002 01FD ./help/vector-copy 1AF760A893CE5833 0001 009E ./help/system 3637646FA0493CB7 0001 00D7 ./help/environ 2EC1027750EC3C80 0001 0180 ./help/queens BF32658E140676F2 0001 018F ./help/collect A60DB03982A42D1B 0001 00EF ./help/argv 1638010AD47E5B59 0044 011B ./edoc/s9-real.c.edoc 10BB9A2482038008 0031 0074 ./edoc/s9-real.scm.edoc 51AC63F2097759B7 01EC 016F ./edoc/s9.c.edoc ABED8A976B6661E0 004F 005B ./edoc/s9.h.edoc 26E6CB5E1931140C 0057 0101 ./edoc/s9.scm.edoc 4FE22583BA6C82C9 0007 01DF ./edoc/Makefile 00000000044FF10E 0001 0014 ./edoc/reset-c B41F19FC4EF39C7F 0002 015C ./edoc/f09.tr 9EA55E704D5102EC 0003 00C5 ./edoc/index.html 22E871B59E111BAE 0002 0015 ./edoc/f04.tr 68AC3E26FF504729 0002 014B ./edoc/f08.tr 46E68139CF3BF432 0031 010F ./edoc/matcher.scm.edoc 29145744B5C01ECC 0002 0016 ./edoc/f15.tr 5AE569D3944562B0 0005 016C ./edoc/f02.tr FE27E4FE63AAA103 0001 0109 ./edoc/f16.tr 899CD2BAD2F19723 0002 013C ./edoc/f07.tr 000000000537F23E 0001 0014 ./edoc/reset-scm E524631A315D68AF 0001 0184 ./edoc/f01.tr DEFA195FD5C35167 0009 00AA ./edoc/toc.edoc F24268E9CF15D003 0008 0118 ./edoc/cover.lt 904214C27CAD2524 0002 010D ./edoc/f06.tr 7CC2C12EFC553AB1 0024 0148 ./edoc/syntax-rules.scm.edoc FC256250C3DDB53F 0009 0012 ./edoc/preface.edoc 766412F174D5F224 0002 0139 ./edoc/f05.tr E07AB7B7DB496EB4 0001 00C1 ./edoc/pngwrite 5D80B5EE1BDE592E 0008 0003 ./edoc/extensions.edoc CBD5A7436B73AFA2 0002 0103 ./edoc/f03.tr 2D50E2F07FAA2691 0003 0041 ./edoc/f13.tr 796E862AC006830A 0001 0142 ./edoc/f11.tr 60C26813AEB37446 0001 01B1 ./edoc/f14.tr 74032A117291E724 0001 00F8 ./edoc/f17.tr 2F3475ADD08A64F7 0003 016B ./edoc/f18.tr 2E7E589879F3E120 0004 002E ./edoc/f19.tr 3A7D9452C59600EB 0001 0110 ./edoc/f24.tr 711D2FE6C9A8118B 0001 0187 ./edoc/f25.tr 265047732B90408D 0005 0154 ./edoc/f26.tr CFCBA8ADB42E8ED2 0002 01A6 ./edoc/f20.tr FDF964ACC3A3B44E 0002 00DF ./edoc/f12.tr 7901CC1A27E6AFC2 0001 01F0 ./edoc/f27.tr 2BFA963EBEEB742B 0003 005A ./edoc/f28.tr 82511D31919DA229 0003 0045 ./edoc/f10.tr 86D16C196E7B585C 0015 011E ./edoc/ascii-diagrams BC34CF38C42D94AC 0002 0097 ./edoc/f30.tr 4BD157684DA6F195 0002 01C7 ./edoc/f31.tr DC89F8F4AF25E13F 06C7 0194 ./edoc/s9.lt 31D7C04B73033614 0099 0191 ./edoc/ndx.html C7CAB1916039C25B 0012 0100 ./edoc/HACKING.edoc AEA89611D9553DEC 0011 01B9 ./MASCOT.png 10BB43D00B225A94 0002 0075 ./configure s9/contrib/000755 001751 001751 00000000000 12076277221 012467 5ustar00nmhnmh000000 000000 s9/ext/000755 001751 001751 00000000000 11454524770 011632 5ustar00nmhnmh000000 000000 s9/lib/000755 001751 001751 00000000000 12076017371 011573 5ustar00nmhnmh000000 000000 s9/s9.c000644 001751 001751 00000341145 12245412465 011535 0ustar00nmhnmh000000 000000 /* DO NOT EDIT THIS FILE! EDIT "edoc/s9.c.edoc" INSTEAD. */ /* * Scheme 9 from Empty Space * By Nils M Holm, 2007-2013 * Placed in the Public Domain */ /* * Use -DNO_SIGNALS to disable POSIX signal handlers. * Use -DBITS_PER_WORD_64 on 64-bit systems. * Use -DREALNUM to enable real number support * (also add "s9-real.scm" to the heap image). */ #define VERSION "2013-11-26" #define EXTERN #include "s9.h" #undef EXTERN #ifndef EXTENSIONS #define EXTENSIONS #endif int Verbose_GC = 0; cell *GC_root[] = { &Program, &Symbols, &Environment, &Tmp, &Tmp_car, &Tmp_cdr, &Stack, &Stack_bottom, &State_stack, &Acc, &Trace_list, &File_list, NULL }; /* * Counting */ int Run_stats, Cons_stats; struct counter { int n, n1k, n1m, n1g, n1t; }; struct counter Reductions, Conses, Nodes, Collections; void reset_counter(struct counter *c) { c->n = 0; c->n1k = 0; c->n1m = 0; c->n1g = 0; c->n1t = 0; } void count(struct counter *c) { char msg[] = "statistics counter overflow"; c->n++; if (c->n >= 1000) { c->n -= 1000; c->n1k++; if (c->n1k >= 1000) { c->n1k -= 1000; c->n1m++; if (c->n1m >= 1000) { c->n1m -= 1000; c->n1g++; if (c->n1g >= 1000) { c->n1t -= 1000; c->n1t++; if (c->n1t >= 1000) { error(msg, NOEXPR); } } } } } } cell counter_to_list(struct counter *c) { cell n, m; n = make_integer(c->n); n = cons(n, NIL); save(n); m = make_integer(c->n1k); n = cons(m, n); car(Stack) = n; m = make_integer(c->n1m); n = cons(m, n); car(Stack) = n; m = make_integer(c->n1g); n = cons(m, n); car(Stack) = n; m = make_integer(c->n1t); n = cons(m, n); unsave(1); return n; } cell error(char *msg, cell expr); void flush(void) { fflush(Ports[Output_port]); } void pr_raw(char *s, int k) { if (Printer_limit && Printer_count > Printer_limit) { if (Printer_limit > 0) fwrite("...", 1, 3, Ports[Output_port]); Printer_limit = -1; return; } fwrite(s, 1, k, Ports[Output_port]); if (Output_port == 1 && s[k-1] == '\n') flush(); Printer_count += k; } void pr(char *s) { if (Ports[Output_port] == NULL) error("output port is not open", NOEXPR); else pr_raw(s, strlen(s)); } /* * Error Handling */ void reset_tty(void) { #ifdef CURSES_RESET cell pp_curs_endwin(cell); pp_curs_endwin(NIL); #endif } void bye(int n) { reset_tty(); exit(n); } void print_form(cell n); void print_error_form(cell n) { Printer_limit = 50; Printer_count = 0; print_form(n); Printer_limit = 0; } void print_calltrace(void) { int i, j; for (i=0; i= Proc_max) i = 0; if (Called_procedures[i] != NIL) { pr(" "); print_form(Called_procedures[i]); } i++; } nl(); } void reset_tty(void); cell error(char *msg, cell expr) { int oport; char buf[100]; if (Error_flag) return UNSPECIFIC; oport = Output_port; Output_port = Quiet_mode? 2: 1; Error_flag = 1; pr("error: "); if (box_value(S_loading) == TRUE) { if (File_list != NIL) { print_form(car(File_list)); pr(": "); } sprintf(buf, "%d: ", Line_no); pr(buf); } pr(msg); if (expr != NOEXPR) { pr(": "); Error_flag = 0; print_error_form(expr); Error_flag = 1; } nl(); print_calltrace(); Output_port = oport; if (Quiet_mode) bye(1); return UNSPECIFIC; } void fatal(char *msg) { pr("fatal "); Error_flag = 0; error(msg, NOEXPR); bye(2); } /* * Memory Management */ void new_cons_segment(void) { Car = realloc(Car, sizeof(cell) * (Cons_pool_size+Cons_segment_size)); Cdr = realloc(Cdr, sizeof(cell) * (Cons_pool_size+Cons_segment_size)); Tag = realloc(Tag, Cons_pool_size + Cons_segment_size); if (Car == NULL || Cdr == NULL || Tag == NULL) fatal("new_cons_segment: out of physical memory"); memset(&car(Cons_pool_size), 0, Cons_segment_size * sizeof(cell)); memset(&cdr(Cons_pool_size), 0, Cons_segment_size * sizeof(cell)); memset(&Tag[Cons_pool_size], 0, Cons_segment_size); Cons_pool_size += Cons_segment_size; Cons_segment_size = Cons_segment_size * 3 / 2; } void new_vec_segment(void) { Vectors = realloc(Vectors, sizeof(cell) * (Vec_pool_size + Vec_segment_size)); if (Vectors == NULL) fatal("out of physical memory"); memset(&Vectors[Vec_pool_size], 0, Vec_segment_size * sizeof(cell)); Vec_pool_size += Vec_segment_size; Vec_segment_size = Vec_segment_size * 3 / 2; } /* * Mark nodes which can be accessed through N. * Using the Deutsch/Schorr/Waite pointer reversal algorithm. * S0: M==0, S==0, unvisited, process CAR (vectors: process 1st slot); * S1: M==1, S==1, CAR visited, process CDR (vectors: process next slot); * S2: M==1, S==0, completely visited, return to parent. */ void mark(cell n) { cell p, parent, *v; int i; parent = NIL; /* Initially, there is no parent node */ while (1) { if (special_value_p(n) || Tag[n] & MARK_TAG) { if (parent == NIL) break; if (Tag[parent] & VECTOR_TAG) { /* S1 --> S1|done */ i = vector_index(parent); v = vector(parent); if (Tag[parent] & STATE_TAG && i+1 < vector_len(parent) ) { /* S1 --> S1 */ p = v[i+1]; v[i+1] = v[i]; v[i] = n; n = p; vector_index(parent) = i+1; } else { /* S1 --> done */ p = parent; parent = v[i]; v[i] = n; n = p; } } else if (Tag[parent] & STATE_TAG) { /* S1 --> S2 */ p = cdr(parent); cdr(parent) = car(parent); car(parent) = n; Tag[parent] &= ~STATE_TAG; Tag[parent] |= MARK_TAG; n = p; } else { /* S2 --> done */ p = parent; parent = cdr(p); cdr(p) = n; n = p; } } else { if (Tag[n] & VECTOR_TAG) { /* S0 --> S1|S2 */ Tag[n] |= MARK_TAG; /* Tag[n] &= ~STATE_TAG; */ vector_link(n) = n; if (car(n) == T_VECTOR && vector_len(n) != 0) { Tag[n] |= STATE_TAG; vector_index(n) = 0; v = vector(n); p = v[0]; v[0] = parent; parent = n; n = p; } } else if (Tag[n] & ATOM_TAG) { /* S0 --> S2 */ if (input_port_p(n) || output_port_p(n)) Port_flags[port_no(n)] |= USED_TAG; p = cdr(n); cdr(n) = parent; /*Tag[n] &= ~STATE_TAG;*/ parent = n; n = p; Tag[parent] |= MARK_TAG; } else { /* S0 --> S1 */ p = car(n); car(n) = parent; Tag[n] |= MARK_TAG; parent = n; n = p; Tag[parent] |= STATE_TAG; } } } } /* Mark and sweep GC. */ int gc(void) { int i, k; char buf[100]; if (Run_stats) count(&Collections); for (i=0; i 1) { sprintf(buf, "GC: %d nodes reclaimed", k); pr(buf); nl(); } return k; } /* Allocate a fresh node and initialize with PCAR,PCDR,PTAG. */ cell cons3(cell pcar, cell pcdr, int ptag) { cell n; int k; char buf[100]; if (Run_stats) { count(&Nodes); if (Cons_stats) count(&Conses); } if (Free_list == NIL) { if (ptag == 0) Tmp_car = pcar; if (ptag != VECTOR_TAG && ptag != PORT_TAG) Tmp_cdr = pcdr; k = gc(); /* * Performance increases dramatically if we * do not wait for the pool to run dry. * In fact, don't even let it come close to that. */ if (k < Cons_pool_size / 2) { if ( Memory_limit_kn && Cons_pool_size + Cons_segment_size > Memory_limit_kn ) { error("hit memory limit", NOEXPR); } else { new_cons_segment(); if (Verbose_GC) { sprintf(buf, "GC: new segment," " nodes = %d," " next segment = %d", Cons_pool_size, Cons_segment_size); pr(buf); nl(); } gc(); } } Tmp_car = Tmp_cdr = NIL; } if (Free_list == NIL) fatal("cons3: failed to recover from low memory condition"); n = Free_list; Free_list = cdr(Free_list); car(n) = pcar; cdr(n) = pcdr; Tag[n] = ptag; return n; } /* Mark all vectors unused */ void unmark_vectors(void) { int p, k, link; p = 0; while (p < Free_vecs) { link = p; k = Vectors[p + RAW_VECTOR_SIZE]; p += vector_size(k); Vectors[link] = NIL; } } /* In situ vector pool garbage collection and compaction */ int gcv(void) { int v, k, to, from; char buf[100]; unmark_vectors(); gc(); /* re-mark live vectors */ to = from = 0; while (from < Free_vecs) { v = Vectors[from + RAW_VECTOR_SIZE]; k = vector_size(v); if (Vectors[from + RAW_VECTOR_LINK] != NIL) { if (to != from) { memmove(&Vectors[to], &Vectors[from], k * sizeof(cell)); cdr(Vectors[to + RAW_VECTOR_LINK]) = to + RAW_VECTOR_DATA; } to += k; } from += k; } k = Free_vecs - to; if (Verbose_GC > 1) { sprintf(buf, "GC: gcv: %d cells reclaimed", k); pr(buf); nl(); } Free_vecs = to; return k; } /* Allocate vector from pool */ cell new_vec(cell type, int size) { cell n; int v, wsize, k; char buf[100]; wsize = vector_size(size); if (Free_vecs + wsize >= Vec_pool_size) { k = gcv(); while ( Free_vecs + wsize >= Vec_pool_size - Vec_pool_size / 2 ) { if ( Memory_limit_kn && Vec_pool_size + Vec_segment_size > Memory_limit_kn ) { error("hit memory limit", NOEXPR); break; } else { new_vec_segment(); gcv(); if (Verbose_GC) { sprintf(buf, "GC: new_vec: new segment," " cells = %d", Vec_pool_size); pr(buf); nl(); } } } } if (Free_vecs + wsize >= Vec_pool_size) fatal("new_vec: failed to recover from low memory condition"); v = Free_vecs; Free_vecs += wsize; n = cons3(type, v + RAW_VECTOR_DATA, VECTOR_TAG); Vectors[v + RAW_VECTOR_LINK] = n; Vectors[v + RAW_VECTOR_INDEX] = 0; Vectors[v + RAW_VECTOR_SIZE] = size; return n; } /* Pop K nodes off the Stack, return last one. */ cell unsave(int k) { cell n = NIL; /*LINT*/ while (k) { if (Stack == NIL) fatal("unsave: stack underflow"); n = car(Stack); Stack = cdr(Stack); k--; } return n; } /* * Reader */ cell find_symbol(char *s) { cell y; y = Symbols; while (y != NIL) { if (!strcmp(symbol_name(car(y)), s)) return car(y); y = cdr(y); } return NIL; } cell make_symbol(char *s, int k) { cell n; n = new_vec(T_SYMBOL, k+1); strcpy(symbol_name(n), s); return n; } cell symbol_ref(char *s) { cell y, new; y = find_symbol(s); if (y != NIL) return y; new = make_symbol(s, (int) strlen(s)); Symbols = cons(new, Symbols); return car(Symbols); } cell read_form(int flags); cell read_list(int flags, int delim) { cell n, /* Node read */ m, /* List */ a; /* Used to append nodes to m */ int c; /* Member counter */ cell new; char badpair[] = "malformed pair"; if (++Level > MAX_IO_DEPTH) { error("reader: too many nested lists or vectors", NOEXPR); return NIL; } m = cons3(NIL, NIL, flags); /* root */ save(m); a = NIL; c = 0; while (1) { if (Error_flag) { unsave(1); return NIL; } n = read_form(flags); if (n == END_OF_FILE) { if (Load_level) { unsave(1); return END_OF_FILE; } error("missing ')'", NOEXPR); } if (n == DOT) { if (c < 1) { error(badpair, NOEXPR); continue; } n = read_form(flags); cdr(a) = n; if (n == delim || read_form(flags) != delim) { error(badpair, NOEXPR); continue; } unsave(1); Level--; return m; } if (n == RPAREN || n == RBRACK) { if (n != delim) error(n == RPAREN? "list starting with `[' ended with `)'": "list starting with `(' ended with `]'", NOEXPR); break; } if (a == NIL) a = m; /* First member: insert at root */ else a = cdr(a); /* Subsequent members: append */ car(a) = n; new = cons3(NIL, NIL, flags); /* Space for next member */ cdr(a) = new; c++; } Level--; if (a != NIL) cdr(a) = NIL; /* Remove trailing empty node */ unsave(1); return c? m: NIL; } cell quote(cell n, cell quotation) { cell q; q = cons(n, NIL); return cons(quotation, q); } #ifdef REALNUM #include "s9-real.c" #define SYM_CHARS "!@#$%^&*-/_+=~.?<>:" #else /* !REALNUM */ #define string_to_number(x) string_to_bignum(x) #define SYM_CHARS "!@$%^&*-/_+=~.?<>:" #define bignum_to_real(x) (x) #define integer_argument(a,b) (b) #define real_abs bignum_abs #define real_add bignum_add #define real_equal_p bignum_equal_p #define real_integer_p integer_p #define real_less_p bignum_less_p #define real_multiply bignum_multiply #define real_negate bignum_negate #define real_negative_p _bignum_negative_p #define real_positive_p _bignum_positive_p #define real_subtract bignum_subtract #define real_zero_p _bignum_zero_p int string_numeric_p(char *s) { int i; int got_d, got_e, got_dp, got_s; i = 0; got_s = 0; got_d = 0; got_dp = 0; got_e = 0; if (s[0] == '+' || s[0] == '-') { i = 1; got_s = 1; } if (!s[i]) return 0; while (s[i]) { if (!isdigit(s[i])) return 0; i++; } return 1; } cell string_to_bignum(char *s) { cell n, v; int k, j, sign; sign = 1; if (s[0] == '-') { s++; sign = -1; } else if (s[0] == '+') { s++; } /* plan9's atol() interprets leading 0 as octal! */ while (s[0] == '0' && s[1]) s++; k = (int) strlen(s); n = NIL; while (k) { j = k <= DIGITS_PER_WORD? k: DIGITS_PER_WORD; v = atol(&s[k-j]); s[k-j] = 0; k -= j; if (k == 0) v *= sign; n = new_atom(v, n); } return new_atom(T_INTEGER, n); } #endif /* !REALNUM */ /* Create a character literal. */ cell make_char(int x) { cell n; n = new_atom(x & 0xff, NIL); return new_atom(T_CHAR, n); } int strcmp_ci(char *s1, char *s2) { int c1, c2; while (1) { c1 = tolower((int) *s1++); c2 = tolower((int) *s2++); if (!c1 || !c2 || c1 != c2) break; } return c1c2? 1: 0; } /* Read a character literal. */ cell read_character(void) { char buf[10], msg[50]; int i, c = 0; /*LINT*/ for (i=0; i 0 && !isalpha(c)) break; buf[i] = c; } reject(c); buf[i] = 0; if (i == 0) c = ' '; else if (i == 1) c = buf[0]; else if (!strcmp_ci(buf, "space")) c = ' '; else if (!strcmp_ci(buf, "newline")) c = '\n'; else { sprintf(msg, "unknown character: #\\%s", buf); error(msg, NOEXPR); c = 0; } return make_char(c); } /* Create a string; K = length */ cell make_string(char *s, int k) { cell n; n = new_vec(T_STRING, k+1); strncpy(string(n), s, k+1); return n; } /* Read a string literal. */ cell read_string(void) { char s[TOKEN_LENGTH+1]; cell n; int c, i, q; int inv; i = 0; q = 0; c = read_c(); inv = 0; while (q || c != '"') { if (c == EOF) error("missing '\"' in string literal", NOEXPR); if (Error_flag) break; if (i >= TOKEN_LENGTH-2) { error("string literal too long", NOEXPR); i--; } if (q && c != '"' && c != '\\') { s[i++] = '\\'; inv = 1; } s[i] = c; q = !q && c == '\\'; if (!q) i++; c = read_c(); } s[i] = 0; n = make_string(s, i); Tag[n] |= CONST_TAG; if (inv) error("invalid escape sequence in string", n); return n; } /* Report unreadable object */ cell unreadable(void) { int c, i; char buf[TOKEN_LENGTH]; int d; strcpy(buf, "#<"); i = 2; while (1) { c = read_c_ci(); if (c == '>' || c == '\n') { if (c == '\n') Line_no++; break; } if (i < TOKEN_LENGTH-2) buf[i++] = c; } buf[i++] = '>'; buf[i] = 0; d = Displaying; Displaying = 1; error("unreadable object", make_string(buf, i)); Displaying = d; return NIL; } #define separator(c) \ ((c) == ' ' || (c) == '\t' || (c) == '\n' || \ (c) == '\r' || (c) == '(' || (c) == ')' || \ (c) == ';' || (c) == '\'' || (c) == '`' || \ (c) == ',' || (c) == '"' || (c) == '[' || \ (c) == ']' || (c) == EOF) #define is_symbolic(c) \ (isalpha(c) || \ isdigit(c) || \ strchr(SYM_CHARS, (c))) cell funny_char(char *msg, int c) { char buf[128]; if (isprint(c)) return error(msg, make_char(c)); sprintf(buf, "%s, code", msg); return error(buf, make_integer(c)); } cell read_symbol_or_number(int c) { char s[TOKEN_LENGTH]; int i, funny = 0; i = 0; while (!separator(c)) { if (!is_symbolic(c)) funny = c; if (i >= TOKEN_LENGTH-2) { error("symbol too long", NOEXPR); i--; } s[i] = c; i++; c = read_c_ci(); } s[i] = 0; reject(c); if (funny) return funny_char("funny character in symbol", funny); if (string_numeric_p(s)) return string_to_number(s); if (!strcmp(s, "define-macro")) return S_define_syntax; return symbol_ref(s); } cell list_to_vector(cell m, char *msg, int flags) { cell n, vec; int k; cell *p; k = 0; for (n = m; n != NIL; n = cdr(n)) { if (atom_p(n)) return error(msg, m); k++; } vec = new_vec(T_VECTOR, k*sizeof(cell)); Tag[vec] |= flags; p = vector(vec); for (n = m; n != NIL; n = cdr(n)) { *p = car(n); p++; } return vec; } cell read_vector(void) { cell n; n = read_list(0, RPAREN); save(n); n = list_to_vector(n, "invalid vector syntax", CONST_TAG); unsave(1); return n; } cell meta_command(void) { int c, cmd, i; cell n, cmdsym; char s[128]; cmd = read_c_ci(); c = read_c(); while (c == ' ') c = read_c(); i = 0; while (c != '\n' && c != EOF) { if (i < sizeof(s) - 2) s[i++] = c; c = read_c(); } reject(c); s[i] = 0; n = make_string(s, strlen(s)); n = i == 0? NIL: cons(n, NIL); switch (cmd) { case 'a': cmdsym = symbol_ref("apropos"); break; case 'h': cmdsym = symbol_ref("help"); break; case 'l': cmdsym = symbol_ref("load-from-library"); break; case 'q': cmdsym = symbol_ref("sys:exit"); break; default: pr(",a = apropos"); nl(); pr(",h = help"); nl(); pr(",l = load-from-library"); nl(); pr(",q = sys:exit"); nl(); return UNSPECIFIC; } return cons(cmdsym, n); } int block_comment(void) { int n, c, state = 0; for (n=1; n; ) { c = read_c_ci(); switch (c) { case EOF: error("missing |#", NOEXPR); return 0; case '|': switch (state) { case 1: n++; state = 0; break; default: state = -1; break; } break; case '#': switch (state) { case -1: n--; state = 0; break; default: state = 1; break; } break; case '\n': Line_no++; state = 0; break; default: state = 0; break; } } return read_c_ci(); } int closing_paren(void) { int c = read_c_ci(); reject(c); return c == ')'; } cell bignum_read(char *pre, int radix); cell read_form(int flags) { char buf[50]; int c, c2; c = read_c_ci(); while (1) { /* Skip over spaces and comments */ while (c == ' ' || c == '\t' || c == '\n' || c == '\r') { if (c == '\n') Line_no++; if (Error_flag) return NIL; c = read_c_ci(); } if (c == '#') { c = read_c_ci(); if (c == '!') { /**/ } else if (c == '|') { c = block_comment(); continue; } else { reject(c); c = '#'; break; } } else if (c != ';') break; while (!Error_flag && c != '\n' && c != EOF) c = read_c_ci(); if (Error_flag) return UNSPECIFIC; } if (c == EOF) return END_OF_FILE; if (Error_flag) return UNSPECIFIC; if (c == '(') { return read_list(flags, RPAREN); } else if (c == '[') { return read_list(flags, RBRACK); } else if (c == '\'' || c == '`') { cell n; if (closing_paren()) return error("missing form after \"'\" or \"`\"", NOEXPR); Level++; n = quote(read_form(CONST_TAG), c=='`'? S_quasiquote: S_quote); Level--; return n; } else if (c == ',') { if (closing_paren()) return error("missing form after \",\"", NOEXPR); c = read_c_ci(); if (c == '@') { return quote(read_form(0), S_unquote_splicing); } else { reject(c); if (!Level) return meta_command(); return quote(read_form(0), S_unquote); } } else if (c == '#') { c = read_c_ci(); switch (c) { case 'f': return FALSE; case 't': return TRUE; case '\\': return read_character(); case '(': return read_vector(); case 'b': return bignum_read("#b", 2); case 'd': return bignum_read("#d", 10); case 'o': return bignum_read("#o", 8); case 'x': return bignum_read("#x", 16); #ifdef REALNUM case 'e': return read_real_number(0); case 'i': return read_real_number(1); #endif case '<': return unreadable(); default: sprintf(buf, "unknown # syntax: #%c", c); return error(buf, NOEXPR); } } else if (c == '"') { return read_string(); } else if (c == ')') { if (!Level) return error("unexpected ')'", NOEXPR); return RPAREN; } else if (c == ']') { if (!Level) return error("unexpected ']'", NOEXPR); return RBRACK; } else if (c == '.') { c2 = read_c_ci(); reject(c2); if (separator(c2)) { if (!Level) return error("unexpected '.'", NOEXPR); return DOT; } return read_symbol_or_number(c); } else if (is_symbolic(c)) { return read_symbol_or_number(c); } else { return funny_char("funny input character", c); } } cell xread(void) { if (Ports[Input_port] == NULL) return error("input port is not open", NOEXPR); Level = 0; return read_form(0); } /* * Printer */ char *ntoa(char *b, cell x, int w) { char buf[40]; int i = 0, neg = 0; char *p = &buf[sizeof(buf)-1]; if (x < 0) { x = -x; neg = 1; } *p = 0; while (x || i == 0) { i++; if (i >= sizeof(buf)-1) fatal("ntoa: number too big"); p--; *p = x % 10 + '0'; x = x / 10; } while (i < (w-neg) && i < sizeof(buf)-1) { i++; p--; *p = '0'; } if (neg) { if (i >= sizeof(buf)-1) fatal("ntoa: number too big"); p--; *p = '-'; } strcpy(b, p); return b; } /* Print bignum integer. */ int print_integer(cell n) { int first; char buf[DIGITS_PER_WORD+2]; if (!integer_p(n)) return 0; n = cdr(n); first = 1; while (n != NIL) { pr(ntoa(buf, car(n), first? 0: DIGITS_PER_WORD)); n = cdr(n); first = 0; } return 1; } /* Print expressions of the form (QUOTE X) as 'X. */ int print_quoted(cell n) { if ( car(n) == S_quote && cdr(n) != NIL && cddr(n) == NIL ) { pr("'"); print_form(cadr(n)); return 1; } return 0; } int print_procedure(cell n) { if (procedure_p(n)) { pr("#"); return 1; } return 0; } int print_continuation(cell n) { if (continuation_p(n)) { pr("#"); return 1; } return 0; } int print_char(cell n) { char b[1]; int c; if (!char_p(n)) return 0; if (!Displaying) pr("#\\"); c = cadr(n); if (!Displaying && c == ' ') pr("space"); else if (!Displaying && c == '\n') pr("newline"); else { b[0] = c; pr_raw(b, 1); } return 1; } int print_string(cell n) { char b[1]; int k; char *s; if (!string_p(n)) return 0; if (!Displaying) pr("\""); s = string(n); k = string_len(n)-1; while (k) { b[0] = *s++; if (!Displaying && (b[0] == '"' || b[0] == '\\')) pr("\\"); pr_raw(b, 1); k--; } if (!Displaying) pr("\""); return 1; } int print_symbol(cell n) { char b[2]; int k; char *s; if (!symbol_p(n)) return 0; s = symbol_name(n); k = symbol_len(n)-1; b[1] = 0; while (k) { b[0] = *s++; pr(b); k--; } return 1; } int print_primitive(cell n) { PRIM *p; if (!primitive_p(n)) return 0; pr("#name); pr(">"); return 1; } int print_syntax(cell n) { if (!syntax_p(n)) return 0; pr("#"); return 1; } int print_vector(cell n) { cell *p; int k; if (!vector_p(n)) return 0; pr("#("); p = vector(n); k = vector_len(n); while (k--) { print_form(*p++); if (k) pr(" "); } pr(")"); return 1; } int print_port(cell n) { char buf[100]; if (!input_port_p(n) && !output_port_p(n)) return 0; sprintf(buf, "#<%s-port %d>", input_port_p(n)? "input": "output", (int) port_no(n)); pr(buf); return 1; } void _print_form(cell n, int depth) { if (Ports[Output_port] == NULL) { error("output port is not open", NOEXPR); return; } if (depth > MAX_IO_DEPTH) { error("printer: too many nested lists or vectors", NOEXPR); return; } if (n == NIL) { pr("()"); } else if (eof_p(n)) { pr("#"); } else if (n == NAN) { pr("#"); } else if (n == FALSE) { pr("#f"); } else if (n == TRUE) { pr("#t"); } else if (undefined_p(n)) { pr("#"); } else if (unspecific_p(n)) { pr("#"); } else { if (print_char(n)) return; if (print_procedure(n)) return; if (print_continuation(n)) return; #ifdef REALNUM if (print_real(n)) return; #endif if (print_integer(n)) return; if (print_primitive(n)) return; if (print_quoted(n)) return; if (print_string(n)) return; if (print_symbol(n)) return; if (print_syntax(n)) return; if (print_vector(n)) return; if (print_port(n)) return; pr("("); while (n != NIL) { if (Error_flag) return; if (Printer_limit && Printer_count > Printer_limit) return; _print_form(car(n), depth+1); if (Error_flag) return; n = cdr(n); if (n != NIL && atom_p(n)) { pr(" . "); _print_form(n, depth+1); n = NIL; } if (n != NIL) pr(" "); } pr(")"); } } void print_form(cell n) { _print_form(n, 0); } /* * Special Form Handlers */ int proper_list_p(cell n) { while (pair_p(n)) n = cdr(n); return n == NIL; } int length(cell n) { int k = 0; while (n != NIL) { k++; n = cdr(n); } return k; } cell append_b(cell a, cell b) { cell p, last = NIL; if (a == NIL) return b; p = a; while (p != NIL) { if (atom_p(p)) fatal("append!: improper list"); last = p; p = cdr(p); } cdr(last) = b; return a; } cell flat_copy(cell n, cell *lastp) { cell a, m, last, new; if (n == NIL) { if (lastp != NULL) lastp[0] = NIL; return NIL; } m = cons3(NIL, NIL, Tag[n]); save(m); a = m; last = m; while (n != NIL) { car(a) = car(n); last = a; n = cdr(n); if (n != NIL) { new = cons3(NIL, NIL, Tag[n]); cdr(a) = new; a = cdr(a); } } unsave(1); if (lastp != NULL) lastp[0] = last; return m; } int argument_list_p(cell n) { if (n == NIL || symbol_p(n)) return 1; if (atom_p(n)) return 0; while (pair_p(n)) { if (!symbol_p(car(n))) return 0; n = cdr(n); } return n == NIL || symbol_p(n); } #define hash(s, h) \ do { \ h = 0; \ while (*s) \ h = (h<<3) ^ *s++; \ } while (0) int hash_size(int n) { if (n < 5) return 5; if (n < 11) return 11; if (n < 23) return 23; if (n < 47) return 47; if (n < 97) return 97; if (n < 199) return 199; if (n < 499) return 499; if (n < 997) return 997; if (n < 9973) return 9973; return 19997; } void rehash(cell e) { unsigned int i; cell p, *v, new; unsigned int h, k = hash_size(length(e)); char *s; if (Program == NIL || k < HASH_THRESHOLD) return; new = new_vec(T_VECTOR, k * sizeof(cell)); car(e) = new; v = vector(car(e)); for (i=0; i= HASH_THRESHOLD) { save(e); rehash(rib); unsave(1); } return e; } cell try_hash(cell v, cell e) { cell *hv, p; unsigned int h, k; char *s; if (e == NIL || car(e) == NIL) return NIL; hv = vector(car(e)); k = vector_len(car(e)); s = symbol_name(v); hash(s, h); p = hv[h%k]; while (p != NIL) { if (caar(p) == v) return car(p); p = cdr(p); } return NIL; } cell lookup(cell v, cell env, int req) { cell e, n; while (env != NIL) { e = car(env); n = try_hash(v, e); if (n != NIL) return n; if (e != NIL) e = cdr(e); while (e != NIL) { if (v == caar(e)) return car(e); e = cdr(e); } env = cdr(env); } if (!req) return NIL; if (special_p(v)) error("invalid syntax", v); else error("symbol not bound", v); return NIL; } cell too_few_args(int n) { return error("too few arguments", n); } cell too_many_args(int n) { return error("too many arguments", n); } /* Set up sequence for AND, BEGIN, OR. */ cell make_sequence(int state, cell neutral, cell x, int *pc, int *ps) { if (cdr(x) == NIL) { return neutral; } else if (cddr(x) == NIL) { *pc = 1; return cadr(x); } else { *pc = 2; *ps = state; save(cdr(x)); return cadr(x); } } #define sf_and(x, pc, ps) \ make_sequence(EV_AND, TRUE, x, pc, ps) #define sf_begin(x, pc, ps) \ make_sequence(EV_BEGIN, UNSPECIFIC, x, pc, ps) cell sf_cond(cell x, int *pc, int *ps) { cell clauses, p; clauses = cdr(x); p = clauses; while (p != NIL) { if (atom_p(car(p))) return error("cond: invalid syntax", car(p)); p = cdr(p); } if (clauses == NIL) return UNSPECIFIC; if (caar(clauses) == S_else && cdr(clauses) == NIL) { p = cons(TRUE, cdar(clauses)); clauses = cons(p, cdr(clauses)); } save(clauses); *pc = 2; *ps = EV_COND; return caar(clauses); } cell sf_if(cell x, int *pc, int *ps) { cell m, new; m = cdr(x); if (m == NIL || cdr(m) == NIL) return too_few_args(x); if (cddr(m) != NIL && cdddr(m) != NIL) return too_many_args(x); if (cddr(m) == NIL) { new = cons(UNSPECIFIC, NIL); cddr(m) = new; } save(m); *pc = 2; *ps = EV_IF_PRED; return car(m); } cell gensym(char *prefix); cell make_temporaries(cell x) { cell n, v; n = NIL; save(n); while (x != NIL) { v = gensym("g"); n = cons(v, n); car(Stack) = n; x = cdr(x); } unsave(1); return n; } /* * Return (begin (set! x0 t0) * ... * (set! xN tN)) */ cell make_assignments(cell x, cell t) { cell n, asg; n = NIL; save(n); while (x != NIL) { asg = cons(car(t), NIL); asg = cons(car(x), asg); asg = cons(S_set_b, asg); n = cons(asg, n); car(Stack) = n; x = cdr(x); t = cdr(t); } unsave(1); return cons(S_begin, n); } cell make_undefineds(cell x) { cell n; n = NIL; while (x != NIL) { n = cons(UNDEFINED, n); x = cdr(x); } return n; } /* Return ((lambda (v0 ...) * ((lambda (t0 ...) * (begin (set! v0 t0) * ... * body)) * a0 ...)) * # * ...) */ cell make_recursive_lambda(cell v, cell a, cell body) { cell t, n; t = make_temporaries(v); save(t); body = append_b(make_assignments(v, t), body); body = cons(body, NIL); n = cons(t, body); n = cons(S_lambda, n); n = cons(n, a); n = cons(n, NIL); n = cons(v, n); n = cons(S_lambda, n); save(n); n = cons(n, make_undefineds(v)); unsave(2); return n; } enum { VARS, VALS }; /* Extract variables or arguments from a set of DEFINEs. */ cell extract_from_defines(cell x, int part, cell *restp) { cell a, n, new; int k; a = NIL; while (x != NIL) { if (atom_p(x) || atom_p(car(x)) || caar(x) != S_define) break; n = car(x); if ( !proper_list_p(n) || (k = length(n)) < 3 || !argument_list_p(cadr(n)) || (symbol_p(cadr(n)) && k > 3) ) return error("define: invalid syntax", n); if (pair_p(cadr(n))) { /* (define (proc vars) ...) */ if (part == VARS) { a = cons(caadr(n), a); } else { a = cons(NIL, a); save(a); new = cons(cdadr(n), cddr(n)); new = cons(S_lambda, new); car(a) = new; unsave(1); } } else { a = cons(part==VARS? cadr(n): caddr(n), a); } x = cdr(x); } *restp = x; return a; } /* * Rewrite local DEFINEs using LAMBDA and SET!. * This is semantically equivalent to: * * (lambda () ---> (lambda () * (define v0 a0) (letrec ((v0 a0) * ... ...) * body) body) */ cell resolve_local_defines(int x) { cell v, a, n, rest; a = extract_from_defines(x, VALS, &rest); if (Error_flag) return NIL; save(a); v = extract_from_defines(x, VARS, &rest); save(v); if (rest == NIL) rest = cons(UNSPECIFIC, NIL); save(rest); n = make_recursive_lambda(v, a, rest); unsave(3); return n; } cell sf_lambda(cell x) { cell n; int k; k = length(x); if (k < 3) return too_few_args(x); if (!argument_list_p(cadr(x))) return error("malformed argument list", cadr(x)); if (pair_p(caddr(x)) && caaddr(x) == S_define) n = resolve_local_defines(cddr(x)); else if (k > 3) n = cons(S_begin, cddr(x)); else n = caddr(x); n = cons(n, Environment); n = cons(cadr(x), n); return new_atom(T_PROCEDURE, n); } cell sf_quote(cell x) { if (cdr(x) == NIL) return too_few_args(x); if (cddr(x) != NIL) return too_many_args(x); return cadr(x); } #define sf_or(x, pc, ps) \ make_sequence(EV_OR, FALSE, x, pc, ps) cell sf_set_b(cell x, int *pc, int *ps) { cell n; int k; k = length(x); if (k < 3) return too_few_args(x); if (k > 3) return too_many_args(x); if (!symbol_p(cadr(x))) return error("set!: expected symbol, got", cadr(x)); n = lookup(cadr(x), Environment, 1); if (Error_flag) return NIL; save(n); *pc = 2; *ps = EV_SET_VAL; return caddr(x); } cell find_local_variable(cell v, cell e) { if (e == NIL) return NIL; e = cdr(e); while (e != NIL) { if (v == caar(e)) return car(e); e = cdr(e); } return NIL; } cell sf_define(int syntax, cell x, int *pc, int *ps) { cell v, a, n, new; int k; if (car(State_stack) == EV_ARGS) return error(syntax? "define-syntax: invalid context": "define: invalid context", x); k = length(x); if (k < 3) return too_few_args(x); if (symbol_p(cadr(x)) && k > 3) return too_many_args(x); if (!argument_list_p(cadr(x))) return error(syntax? "define-syntax: expected argument list, got": "define: expected argument list, got", cadr(x)); if (!symbol_p(cadr(x))) { a = cddr(x); a = cons(cdadr(x), a); a = cons(S_lambda, a); save(a); n = caadr(x); } else { save(NIL); a = caddr(x); n = cadr(x); } v = find_local_variable(n, car(Environment)); if (v == NIL) { new = extend(n, UNDEFINED, car(Environment)); car(Environment) = new; v = cadar(Environment); } car(Stack) = binding_box(v); *pc = 2; if (syntax) *ps = EV_MACRO; else *ps = EV_SET_VAL; return a; } cell apply_special(cell x, int *pc, int *ps) { cell sf; sf = car(x); if (sf == S_quote) return sf_quote(x); else if (sf == S_if) return sf_if(x, pc, ps); else if (sf == S_and) return sf_and(x, pc, ps); else if (sf == S_or) return sf_or(x, pc, ps); else if (sf == S_cond) return sf_cond(x, pc, ps); else if (sf == S_lambda) return sf_lambda(x); else if (sf == S_begin) return sf_begin(x, pc, ps); else if (sf == S_set_b) return sf_set_b(x, pc, ps); else if (sf == S_define) return sf_define(0, x, pc, ps); else if (sf == S_define_syntax) return sf_define(1, x, pc, ps); else fatal("internal: unknown special form"); return UNSPECIFIC; } /* * Bignums */ cell make_integer(cell i) { cell n; n = new_atom(i, NIL); return new_atom(T_INTEGER, n); } cell integer_value(char *src, cell x) { char msg[100]; #ifdef REALNUM x = integer_argument(src, x); if (x == NIL) return 0; #endif if (cddr(x) != NIL) { sprintf(msg, "%s: integer argument too big", src); error(msg, x); return 0; } return cadr(x); } cell bignum_abs(cell a) { cell n; n = new_atom(labs(cadr(a)), cddr(a)); return new_atom(T_INTEGER, n); } cell bignum_negate(cell a) { cell n; n = new_atom(-cadr(a), cddr(a)); return new_atom(T_INTEGER, n); } cell reverse_segments(cell n) { cell m; m = NIL; while (n != NIL) { m = new_atom(car(n), m); n = cdr(n); } return m; } cell bignum_add(cell a, cell b); cell bignum_subtract(cell a, cell b); cell _bignum_add(cell a, cell b) { cell fa, fb, result, r; int carry; if (_bignum_negative_p(a)) { if (_bignum_negative_p(b)) { /* -A+-B --> -(|A|+|B|) */ a = bignum_abs(a); save(a); a = bignum_add(a, bignum_abs(b)); unsave(1); return bignum_negate(a); } else { /* -A+B --> B-|A| */ return bignum_subtract(b, bignum_abs(a)); } } else if (_bignum_negative_p(b)) { /* A+-B --> A-|B| */ return bignum_subtract(a, bignum_abs(b)); } /* A+B */ a = reverse_segments(cdr(a)); save(a); b = reverse_segments(cdr(b)); save(b); carry = 0; result = NIL; save(result); while (a != NIL || b != NIL || carry) { fa = a == NIL? 0: car(a); fb = b == NIL? 0: car(b); r = fa + fb + carry; carry = 0; if (r >= INT_SEG_LIMIT) { r -= INT_SEG_LIMIT; carry = 1; } result = new_atom(r, result); car(Stack) = result; if (a != NIL) a = cdr(a); if (b != NIL) b = cdr(b); } unsave(3); return new_atom(T_INTEGER, result); } cell bignum_add(cell a, cell b) { Tmp = b; save(a); save(b); Tmp = NIL; a = _bignum_add(a, b); unsave(2); return a; } int bignum_less_p(cell a, cell b) { int ka, kb, neg_a, neg_b; neg_a = _bignum_negative_p(a); neg_b = _bignum_negative_p(b); if (neg_a && !neg_b) return 1; if (!neg_a && neg_b) return 0; ka = length(a); kb = length(b); if (ka < kb) return neg_a? 0: 1; if (ka > kb) return neg_a? 1: 0; Tmp = b; a = bignum_abs(a); save(a); b = bignum_abs(b); unsave(1); Tmp = NIL; a = cdr(a); b = cdr(b); while (a != NIL) { if (car(a) < car(b)) return neg_a? 0: 1; if (car(a) > car(b)) return neg_a? 1: 0; a = cdr(a); b = cdr(b); } return 0; } int bignum_equal_p(cell a, cell b) { a = cdr(a); b = cdr(b); while (a != NIL && b != NIL) { if (car(a) != car(b)) return 0; a = cdr(a); b = cdr(b); } return a == NIL && b == NIL; } cell _bignum_subtract(cell a, cell b) { cell fa, fb, result, r; int borrow; if (_bignum_negative_p(a)) { if (_bignum_negative_p(b)) { /* -A--B --> -A+|B| --> |B|-|A| */ a = bignum_abs(a); save(a); a = bignum_subtract(bignum_abs(b), a); unsave(1); return a; } else { /* -A-B --> -(|A|+B) */ return bignum_negate(bignum_add(bignum_abs(a), b)); } } else if (_bignum_negative_p(b)) { /* A--B --> A+|B| */ return bignum_add(a, bignum_abs(b)); } /* A-B, A -(B-A) */ if (bignum_less_p(a, b)) return bignum_negate(bignum_subtract(b, a)); /* A-B, A>=B */ a = reverse_segments(cdr(a)); save(a); b = reverse_segments(cdr(b)); save(b); borrow = 0; result = NIL; save(result); while (a != NIL || b != NIL || borrow) { fa = a == NIL? 0: car(a); fb = b == NIL? 0: car(b); r = fa - fb - borrow; borrow = 0; if (r < 0) { r += INT_SEG_LIMIT; borrow = 1; } result = new_atom(r, result); car(Stack) = result; if (a != NIL) a = cdr(a); if (b != NIL) b = cdr(b); } unsave(3); while (car(result) == 0 && cdr(result) != NIL) result = cdr(result); return new_atom(T_INTEGER, result); } cell bignum_subtract(cell a, cell b) { Tmp = b; save(a); save(b); Tmp = NIL; a = _bignum_subtract(a, b); unsave(2); return a; } cell bignum_shift_left(cell a, int fill) { cell r, c, result; int carry; a = reverse_segments(cdr(a)); save(a); carry = fill; result = NIL; save(result); while (a != NIL) { if (car(a) >= INT_SEG_LIMIT/10) { c = car(a) / (INT_SEG_LIMIT/10); r = car(a) % (INT_SEG_LIMIT/10) * 10; r += carry; carry = c; } else { r = car(a) * 10 + carry; carry = 0; } result = new_atom(r, result); car(Stack) = result; a = cdr(a); } if (carry) result = new_atom(carry, result); unsave(2); return new_atom(T_INTEGER, result); } /* Result: (a/10 . a%10) */ cell bignum_shift_right(cell a) { cell r, c, result; int carry; a = cdr(a); save(a); carry = 0; result = NIL; save(result); while (a != NIL) { c = car(a) % 10; r = car(a) / 10; r += carry * (INT_SEG_LIMIT/10); carry = c; result = new_atom(r, result); car(Stack) = result; a = cdr(a); } result = reverse_segments(result); if (car(result) == 0 && cdr(result) != NIL) result = cdr(result); result = new_atom(T_INTEGER, result); car(Stack) = result; carry = make_integer(carry); unsave(2); return cons(result, carry); } cell bignum_multiply(cell a, cell b) { int neg; cell r, i, result; neg = _bignum_negative_p(a) != _bignum_negative_p(b); a = bignum_abs(a); save(a); b = bignum_abs(b); save(b); result = make_integer(0); save(result); while (!_bignum_zero_p(a)) { if (Error_flag) break; r = bignum_shift_right(a); i = caddr(r); a = car(r); caddr(Stack) = a; while (i) { result = bignum_add(result, b); car(Stack) = result; i--; } b = bignum_shift_left(b, 0); cadr(Stack) = b; } if (neg) result = bignum_negate(result); unsave(3); return result; } /* * Equalize A and B, e.g.: * A=123, B=12345 ---> 12300, 100 * Return (scaled-a . scaling-factor) */ cell bignum_equalize(cell a, cell b) { cell r, f, r0, f0; r0 = a; save(r0); f0 = make_integer(1); save(f0); r = r0; save(r); f = f0; save(f); while (bignum_less_p(r, b)) { cadddr(Stack) = r0 = r; caddr(Stack) = f0 = f; r = bignum_shift_left(r, 0); cadr(Stack) = r; f = bignum_shift_left(f, 0); car(Stack) = f; } unsave(4); return cons(r0, f0); } /* Result: (a/b . a%b) */ cell _bignum_divide(cell a, cell b) { int neg, neg_a; cell result, f; int i; cell c, c0; neg_a = _bignum_negative_p(a); neg = neg_a != _bignum_negative_p(b); a = bignum_abs(a); save(a); b = bignum_abs(b); save(b); if (bignum_less_p(a, b)) { if (neg_a) a = bignum_negate(a); f = make_integer(0); unsave(2); return cons(f, a); } b = bignum_equalize(b, a); cadr(Stack) = b; /* cadr+cddddr */ car(Stack) = a; /* car+cddddr */ c = NIL; save(c); /* cadddr */ c0 = NIL; save(c0); /* caddr */ f = cdr(b); b = car(b); cadddr(Stack) = b; save(f); /* cadr */ result = make_integer(0); save(result); /* car */ while (!_bignum_zero_p(f)) { if (Error_flag) break; c = make_integer(0); cadddr(Stack) = c; caddr(Stack) = c0 = c; i = 0; while (!bignum_less_p(a, c)) { if (Error_flag) break; caddr(Stack) = c0 = c; c = bignum_add(c, b); cadddr(Stack) = c; i++; } result = bignum_shift_left(result, i-1); car(Stack) = result; a = bignum_subtract(a, c0); car(cddddr(Stack)) = a; f = car(bignum_shift_right(f)); cadr(Stack) = f; b = car(bignum_shift_right(b)); cadr(cddddr(Stack)) = b; } if (neg) result = bignum_negate(result); car(Stack) = result; if (neg_a) a = bignum_negate(a); unsave(6); return cons(result, a); } cell bignum_divide(cell x, cell a, cell b) { if (_bignum_zero_p(b)) return error("divide by zero", x); Tmp = b; save(a); save(b); Tmp = NIL; a = _bignum_divide(a, b); unsave(2); return a; } cell bignum_read(char *pre, int radix) { char digits[] = "0123456789abcdef"; char buf[100]; cell base, num; int c, s, p, nd; base = make_integer(radix); save(base); num = make_integer(0); save(num); c = read_c_ci(); s = 0; if (c == '-') { s = 1; c = read_c_ci(); } else if (c == '+') { c = read_c_ci(); } nd = 0; while (!separator(c)) { p = 0; while (digits[p] && digits[p] != c) p++; if (p >= radix) { sprintf(buf, "invalid digit in %s number", pre); unsave(2); return funny_char(buf, c); } num = bignum_multiply(num, base); car(Stack) = num; num = bignum_add(num, make_integer(p)); car(Stack) = num; nd++; c = read_c_ci(); } unsave(2); if (!nd) { sprintf(buf, "digits expected after %s", pre); return error(buf, NOEXPR); } reject(c); return s? bignum_negate(num): num; } /* * Primitives */ cell pp_apply(cell x) { cell m, p, q, last; m = cdr(x); p = cdr(m); last = p; while (p != NIL) { last = p; p = cdr(p); } p = car(last); while (p != NIL) { if (atom_p(p)) return error("apply: improper argument list", car(last)); p = cdr(p); } if (cddr(m) == NIL) { p = cadr(m); } else { p = flat_copy(cdr(m), &q); q = p; while (cddr(q) != NIL) q = cdr(q); cdr(q) = car(last); } return cons(car(m), p); } cell pp_call_cc(cell x) { cell cc, n; cc = cons(Stack, NIL); cc = cons(Stack_bottom, cc); cc = cons(State_stack, cc); cc = cons(Environment, cc); cc = new_atom(T_CONTINUATION, cc); n = cons(cc, NIL); n = cons(cadr(x), n); return n; } cell resume(cell x) { cell cc; if (cdr(x) == NIL) return too_few_args(x); if (cddr(x) != NIL) return too_many_args(x); cc = cdar(x); Environment = car(cc); State_stack = cadr(cc); Stack_bottom = caddr(cc); Stack = cadddr(cc); return cadr(x); } cell pp_unquote(cell x) { return error("unquote: not in quasiquote context", NOEXPR); } cell pp_unquote_splicing(cell x) { return error("unquote-splicing: not in quasiquote context", NOEXPR); } /* * Predicates and Booleans */ cell pp_eq_p(cell x) { return cadr(x) == caddr(x)? TRUE: FALSE; } int eqv_p(cell a, cell b) { if (a == b) return 1; if (char_p(a) && char_p(b) && char_value(a) == char_value(b)) return 1; if (number_p(a) && number_p(b)) { if (real_p(a) != real_p(b)) return 0; return real_equal_p(a, b); } return a == b; } cell pp_eqv_p(cell x) { return eqv_p(cadr(x), caddr(x))? TRUE: FALSE; } cell pp_not(cell x) { return cadr(x) == FALSE? TRUE: FALSE; } cell pp_null_p(cell x) { return cadr(x) == NIL? TRUE: FALSE; } /* * Pairs and Lists */ cell pp_append2(cell x) { cell new, n, p, a, *pa; if (cadr(x) == NIL) return caddr(x); if (caddr(x) == NIL) { if (pair_p(cadr(x))) return cadr(x); else return error("append2: expected list, got", cadr(x)); } a = n = cons(NIL, NIL); pa = &a; save(n); for (p = cadr(x); p != NIL; p = cdr(p)) { if (!pair_p(p)) return error("append2: improper list", cadr(x)); car(a) = car(p); new = cons(NIL, NIL); cdr(a) = new; pa = &cdr(a); a = cdr(a); } unsave(1); *pa = caddr(x); return n; } int assqv(char *who, int v, cell x, cell a) { cell p; char buf[64]; for (p = a; p != NIL; p = cdr(p)) { if (!pair_p(p) || !pair_p(car(p))) { sprintf(buf, "%s: bad element in alist", who); return error(buf, p); } if (!v && x == caar(p)) return car(p); if (v && eqv_p(x, caar(p))) return car(p); } return FALSE; } cell pp_assq(cell x) { return assqv("assq", 0, cadr(x), caddr(x)); } cell pp_assv(cell x) { return assqv("assv", 1, cadr(x), caddr(x)); } char *rev_cxr_name(char *s) { int i, k = strlen(s); static char buf[8]; for (i=0; i: expected number, got", cadr(x)); if (!real_less_p(cadr(x), car(x))) return FALSE; x = cdr(x); } return TRUE; } cell pp_greater_equal(cell x) { x = cdr(x); while (cdr(x) != NIL) { if (!number_p(cadr(x))) return error(">=: expected number, got", cadr(x)); if (real_less_p(car(x), cadr(x))) return FALSE; x = cdr(x); } return TRUE; } cell pp_less(cell x) { x = cdr(x); while (cdr(x) != NIL) { if (!number_p(cadr(x))) return error("<: expected number, got", cadr(x)); if (!real_less_p(car(x), cadr(x))) return FALSE; x = cdr(x); } return TRUE; } cell pp_less_equal(cell x) { x = cdr(x); while (cdr(x) != NIL) { if (!number_p(cadr(x))) return error("<=: expected number, got", cadr(x)); if (real_less_p(cadr(x), car(x))) return FALSE; x = cdr(x); } return TRUE; } cell limit(char *msg, int(*pred)(cell,cell), cell x) { cell k, p; int exact = 1; k = cadr(x); if (real_p(k)) exact = 0; for (p = cddr(x); p != NIL; p = cdr(p)) { if (!number_p(car(p))) return error(msg, (car(p))); if (real_p(car(p))) exact = 0; if (pred(k, car(p))) k = car(p); } if (exact) return k; if (integer_p(k)) return bignum_to_real(k); return k; } cell pp_max(cell x) { return limit("max: expected number, got", real_less_p, x); } cell pp_minus(cell x) { cell a; x = cdr(x); if (cdr(x) == NIL) return real_negate(car(x)); a = car(x); x = cdr(x); save(a); while (x != NIL) { if (!number_p(car(x))) { unsave(1); return error("-: expected number, got", car(x)); } a = real_subtract(a, car(x)); car(Stack) = a; x = cdr(x); } unsave(1); return a; } int real_greater_p(cell x, cell y) { return real_less_p(y, x); } cell pp_min(cell x) { return limit("max: expected number, got", real_greater_p, x); } cell pp_negative_p(cell x) { return real_negative_p(cadr(x))? TRUE: FALSE; } cell pp_odd_p(cell x) { return even_p("odd?", cadr(x))? FALSE: TRUE; } cell pp_plus(cell x) { cell a; x = cdr(x); if (x == NIL) return make_integer(0); if (cdr(x) == NIL) return car(x); a = make_integer(0); save(a); while (x != NIL) { if (!number_p(car(x))) { unsave(1); return error("+: expected number, got", car(x)); } a = real_add(a, car(x)); car(Stack) = a; x = cdr(x); } unsave(1); return a; } cell pp_quotient(cell x) { char *name = "quotient"; cell a, b; name = name; /*LINT*/ a = integer_argument(name, cadr(x)); save(a); b = integer_argument(name, caddr(x)); unsave(1); if (a == NIL || b == NIL) return UNDEFINED; return car(bignum_divide(x, a, b)); } cell pp_positive_p(cell x) { x = cadr(x); return real_positive_p(x)? TRUE: FALSE; } cell pp_remainder(cell x) { char *name = "remainder"; cell a, b; name = name; /*LINT*/ a = integer_argument(name, cadr(x)); save(a); b = integer_argument(name, caddr(x)); unsave(1); if (a == NIL || b == NIL) return UNDEFINED; return cdr(bignum_divide(x, a, b)); } cell pp_times(cell x) { cell a; x = cdr(x); if (x == NIL) return make_integer(1); if (cdr(x) == NIL) return car(x); a = make_integer(1); save(a); while (x != NIL) { if (!number_p(car(x))) { unsave(1); return error("*: expected number, got", car(x)); } a = real_multiply(a, car(x)); car(Stack) = a; x = cdr(x); } unsave(1); return a; } cell pp_zero_p(cell x) { return real_zero_p(cadr(x))? TRUE: FALSE; } /* * Type Predicates and Conversion */ cell pp_boolean_p(cell x) { return boolean_p(cadr(x))? TRUE: FALSE; } cell pp_char_p(cell x) { return char_p(cadr(x))? TRUE: FALSE; } cell pp_char_to_integer(cell x) { return make_integer(char_value(cadr(x))); } cell pp_input_port_p(cell x) { return input_port_p(cadr(x))? TRUE: FALSE; } cell pp_integer_to_char(cell x) { cell n; n = integer_value("integer->char", cadr(x)); if (n < 0 || n > 255) return error("integer->char: argument value out of range", cadr(x)); return make_char(n); } cell pp_integer_p(cell x) { return real_integer_p(cadr(x))? TRUE: FALSE; } cell list_to_string(char *who, cell x) { cell n; int k = length(x); char *s; char buf[100]; n = make_string("", k); s = string(n); while (x != NIL) { if (atom_p(x)) return error("list->string: improper list", x); if (!char_p(car(x))) { sprintf(buf, "%s: expected list of char," " got list containing", who); return error(buf, car(x)); } *s++ = cadar(x); x = cdr(x); } *s = 0; return n; } cell pp_list_to_string(cell x) { return list_to_string("list->string", cadr(x)); } cell pp_list_to_vector(cell x) { return list_to_vector(cadr(x), "list->vector: improper list", 0); } cell pp_output_port_p(cell x) { return output_port_p(cadr(x))? TRUE: FALSE; } cell pp_pair_p(cell x) { return pair_p(cadr(x))? TRUE: FALSE; } cell pp_procedure_p(cell x) { return (procedure_p(cadr(x)) || primitive_p(cadr(x)) || continuation_p(cadr(x)))? TRUE: FALSE; } cell pp_string_to_list(cell x) { char *s; cell n, a, new; int k, i; k = string_len(cadr(x)); n = NIL; a = NIL; for (i=0; i= L(c2); } int char_ci_gt(int c1, int c2) { return L(c1) > L(c2); } int char_le(int c1, int c2) { return c1 <= c2; } int char_lt(int c1, int c2) { return c1 < c2; } int char_eq(int c1, int c2) { return c1 == c2; } int char_ge(int c1, int c2) { return c1 >= c2; } int char_gt(int c1, int c2) { return c1 > c2; } cell char_predicate(char *name, int (*p)(int c1, int c2), cell x) { char msg[100]; x = cdr(x); while (cdr(x) != NIL) { if (!char_p(cadr(x))) { sprintf(msg, "%s: expected char, got", name); return error(msg, cadr(x)); } if (!p(char_value(car(x)), char_value(cadr(x)))) return FALSE; x = cdr(x); } return TRUE; } #define CP return char_predicate cell pp_char_ci_le_p(cell x) { CP("char-ci<=?", char_ci_le, x); } cell pp_char_ci_lt_p(cell x) { CP("char-ci=?", char_ci_ge, x); } cell pp_char_ci_gt_p(cell x) { CP("char-ci>?", char_ci_gt, x); } cell pp_char_le_p(cell x) { CP("char<=?", char_le, x); } cell pp_char_lt_p(cell x) { CP("char=?", char_ge, x); } cell pp_char_gt_p(cell x) { CP("char>?", char_gt, x); } cell pp_char_downcase(cell x) { return make_char(tolower(char_value(cadr(x)))); } cell pp_char_lower_case_p(cell x) { return islower(char_value(cadr(x)))? TRUE: FALSE; } cell pp_char_numeric_p(cell x) { return isdigit(char_value(cadr(x)))? TRUE: FALSE; } cell pp_char_upcase(cell x) { return make_char(toupper(char_value(cadr(x)))); } cell pp_char_upper_case_p(cell x) { return isupper(char_value(cadr(x)))? TRUE: FALSE; } cell pp_char_whitespace_p(cell x) { int c = char_value(cadr(x)); return (c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f')? TRUE: FALSE; } /* * Strings */ cell pp_make_string(cell x) { cell n; int c, k; char *s; k = integer_value("make-string", cadr(x)); if (k < 0) return error("make-string: got negative length", x); n = make_string("", k); s = string(n); c = cddr(x) == NIL? ' ': char_value(caddr(x)); memset(s, c, k); s[k] = 0; return n; } cell pp_string(cell x) { return list_to_string("string", cdr(x)); } cell pp_string_append(cell x) { cell p, n; int k; char *s; k = 0; for (p = cdr(x); p != NIL; p = cdr(p)) { if (!string_p(car(p))) return error("string-append: expected string, got", car(p)); k += string_len(car(p))-1; } n = make_string("", k); s = string(n); k = 0; for (p = cdr(x); p != NIL; p = cdr(p)) { strcpy(&s[k], string(car(p))); k += string_len(car(p))-1; } return n; } cell pp_string_copy(cell x) { cell n; /* * Cannot pass name to make_string(), because * string(cadr(x)) may move during GC. */ n = make_string("", string_len(cadr(x))-1); strcpy(string(n), string(cadr(x))); return n; } cell pp_string_fill_b(cell x) { int c = char_value(caddr(x)), i, k = string_len(cadr(x))-1; char *s = string(cadr(x)); if (constant_p(cadr(x))) return error("string-fill!: immutable object", cadr(x)); for (i=0; i= k) return error("string-ref: index out of range", caddr(x)); return make_char(string(cadr(x))[p]); } cell pp_string_set_b(cell x) { int p, k = string_len(cadr(x))-1; if (constant_p(cadr(x))) return error("string-set!: immutable object", cadr(x)); p = integer_value("string-set!", caddr(x)); if (p < 0 || p >= k) return error("string-set!: index out of range", caddr(x)); string(cadr(x))[p] = char_value(cadddr(x)); return UNSPECIFIC; } int string_ci_le(char *s1, char *s2) { return strcmp_ci(s1, s2) <= 0; } int string_ci_lt(char *s1, char *s2) { return strcmp_ci(s1, s2) < 0; } int string_ci_eq(char *s1, char *s2) { return strcmp_ci(s1, s2) == 0; } int string_ci_ge(char *s1, char *s2) { return strcmp_ci(s1, s2) >= 0; } int string_ci_gt(char *s1, char *s2) { return strcmp_ci(s1, s2) > 0; } int string_le(char *s1, char *s2) { return strcmp(s1, s2) <= 0; } int string_lt(char *s1, char *s2) { return strcmp(s1, s2) < 0; } int string_eq(char *s1, char *s2) { return strcmp(s1, s2) == 0; } int string_ge(char *s1, char *s2) { return strcmp(s1, s2) >= 0; } int string_gt(char *s1, char *s2) { return strcmp(s1, s2) > 0; } cell string_predicate(char *name, int (*p)(char *s1, char *s2), cell x) { char msg[100]; x = cdr(x); while (cdr(x) != NIL) { if (!string_p(cadr(x))) { sprintf(msg, "%s: expected string, got", name); return error(msg, cadr(x)); } if ( (p == string_eq || p == string_ci_eq) && string_len(car(x)) != string_len(cadr(x)) ) return FALSE; if (!p(string(car(x)), string(cadr(x)))) return FALSE; x = cdr(x); } return TRUE; } #define SP return string_predicate cell pp_string_ci_le_p(cell x) { SP("string-ci<=?", string_ci_le, x); } cell pp_string_ci_lt_p(cell x) { SP("string-ci=?", string_ci_ge, x); } cell pp_string_ci_gt_p(cell x) { SP("string-ci>?", string_ci_gt, x); } cell pp_string_le_p(cell x) { SP("string<=?", string_le, x); } cell pp_string_lt_p(cell x) { SP("string=?", string_ge, x); } cell pp_string_gt_p(cell x) { SP("string>?", string_gt, x); } cell pp_substring(cell x) { int k = string_len(cadr(x))-1; int p0 = integer_value("substring", caddr(x)); int pn = integer_value("substring", cadddr(x)); char *src, *dst; cell n; if (p0 < 0 || p0 > k || pn < 0 || pn > k || pn < p0) { n = cons(cadddr(x), NIL); return error("substring: invalid range", cons(caddr(x), n)); } n = make_string("", pn-p0); dst = string(n); src = string(cadr(x)); if (pn-p0 != 0) memcpy(dst, &src[p0], pn-p0); dst[pn-p0] = 0; return n; } /* * Vectors */ cell pp_make_vector(cell x) { int i, k; cell n, *v, m; k = integer_value("make-vector", cadr(x)); if (k < 0) return error("make-vector: got negative length", x); n = new_vec(T_VECTOR, k * sizeof(cell)); v = vector(n); m = cddr(x) == NIL? FALSE: caddr(x); for (i=0; i kn) return error("vector-copy: bad range", NOEXPR); if (x != NIL) { fill = car(x); x = cdr(x); } if (x != NIL) return error("vector-copy: too many arguments", NOEXPR); n = new_vec(T_VECTOR, (kn-k0) * sizeof(cell)); nv = vector(n); ov = vector(vec); for (j = 0, i = k0; i < kn; i++, j++) if (i >= k) nv[j] = fill; else nv[j] = ov[i]; return n; } cell pp_vector_fill_b(cell x) { cell fill = caddr(x); int i, k = vector_len(cadr(x)); cell *v = vector(cadr(x)); if (constant_p(cadr(x))) return error("vector-fill!: immutable object", cadr(x)); for (i=0; i= k) return error("vector-ref: index out of range", caddr(x)); return vector(cadr(x))[p]; } cell pp_vector_set_b(cell x) { int p, k = vector_len(cadr(x)); if (constant_p(cadr(x))) return error("vector-set!: immutable object", cadr(x)); p = integer_value("vector-set!", caddr(x)); if (p < 0 || p >= k) return error("vector-set!: index out of range", caddr(x)); vector(cadr(x))[p] = cadddr(x); return UNSPECIFIC; } /* * I/O */ void close_port(int port) { if (port < 0 || port >= MAX_PORTS) return; if (Ports[port] == NULL) { Port_flags[port] = 0; return; } fclose(Ports[port]); /* already closed? don't care */ Ports[port] = NULL; Port_flags[port] = 0; } cell pp_close_input_port(cell x) { if (port_no(cadr(x)) < 2) return error("please do not close the standard input port", NOEXPR); close_port(port_no(cadr(x))); return UNSPECIFIC; } cell pp_close_output_port(cell x) { if (port_no(cadr(x)) < 2) return error("please do not close the standard output port", NOEXPR); close_port(port_no(cadr(x))); return UNSPECIFIC; } cell make_port(int portno, cell type) { cell n; int pf; pf = Port_flags[portno]; Port_flags[portno] |= LOCK_TAG; n = new_atom(portno, NIL); n = cons3(type, n, ATOM_TAG|PORT_TAG); Port_flags[portno] = pf; return n; } cell pp_current_input_port(cell x) { return make_port(Input_port, T_INPUT_PORT); } cell pp_current_output_port(cell x) { return make_port(Output_port, T_OUTPUT_PORT); } cell pp_write(cell x); cell pp_display(cell x) { Displaying = 1; pp_write(x); Displaying = 0; return UNSPECIFIC; } cell pp_eof_object_p(cell x) { return cadr(x) == END_OF_FILE? TRUE: FALSE; } int new_port(void) { int i, tries; for (tries=0; tries<2; tries++) { for (i=0; i TOKEN_LENGTH) return error("load: path too long", cadr(x)); strcpy(file, string(cadr(x))); if (load(file) < 0) return error("load: cannot open file", cadr(x)); return UNSPECIFIC; } cell pp_open_input_file(cell x) { int p; p = open_port(string(cadr(x)), "r"); if (p < 0) return error("open-input-file: could not open file", cadr(x)); return make_port(p, T_INPUT_PORT); } cell pp_open_output_file(cell x) { int p; FILE *f; f = fopen(string(cadr(x)), "r"); if (f != NULL) { fclose(f); return error("open-output-file: file already exists", cadr(x)); } p = open_port(string(cadr(x)), "w"); if (p < 0) return error("open-output-file: could not open file", cadr(x)); return make_port(p, T_OUTPUT_PORT); } cell pp_read(cell x) { cell n; int new_port, old_port; new_port = cdr(x) == NIL? Input_port: port_no(cadr(x)); if (new_port < 0 || new_port >= MAX_PORTS) return error("read: invalid input port (oops)", cadr(x)); old_port = Input_port; Input_port = new_port; n = xread(); Input_port = old_port; return n; } cell read_char(cell x, int unget) { int c, new_port, old_port; new_port = cdr(x) == NIL? Input_port: port_no(cadr(x)); if (new_port < 0 || new_port >= MAX_PORTS) return error("read-char: invalid input port (oops)", cadr(x)); if (Ports[new_port] == NULL) return error("read-char: input port is not open", NOEXPR); old_port = Input_port; Input_port = new_port; c = read_c(); if (unget) reject(c); Input_port = old_port; return c == EOF? END_OF_FILE: make_char(c); } cell pp_peek_char(cell x) { return read_char(x, 1); } cell pp_read_char(cell x) { return read_char(x, 0); } cell pp_write(cell x) { int new_port, old_port; new_port = cddr(x) == NIL? Output_port: port_no(caddr(x)); if (new_port < 0 || new_port >= MAX_PORTS) return error("write: invalid output port (oops)", caddr(x)); old_port = Output_port; Output_port = new_port; print_form(cadr(x)); Output_port = old_port; return UNSPECIFIC; } cell pp_write_char(cell x) { return pp_display(x); } /* * S9fES Extentions */ cell pp_bit_op(cell x) { char name[] = "bit-op"; cell op, a, b; static cell mask = 0; if (mask == 0) { mask = 1; while (mask <= INT_SEG_LIMIT) mask <<= 1; if (mask > INT_SEG_LIMIT) mask >>= 1; mask--; } op = integer_value(name, cadr(x)); x = cddr(x); a = integer_value(name, car(x)); for (x = cdr(x); x != NIL; x = cdr(x)) { b = integer_value(name, car(x)); if (a & ~mask || b & ~mask || a < 0 || b < 0) return FALSE; switch (op) { case 0: a = 0; break; case 1: a = a & b; break; case 2: a = a & ~b; break; case 3: a = a; break; case 4: a = ~a & b; break; case 5: a = b; break; case 6: a = a ^ b; break; case 7: a = a | b; break; case 8: a = ~(a | b); break; case 9: a = ~(a ^ b); break; case 10: a = ~b; break; case 11: a = a | ~b; break; case 12: a = ~a; break; case 13: a = ~a | b; break; case 14: a = ~(a & b); break; case 15: a = ~0; break; case 16: a = a << b; break; case 17: a = a >> b; break; default: return FALSE; break; } a &= mask; } return make_integer(a); } char *copy_string(char *s) { char *new; new = malloc(strlen(s)+1); if (s == NULL) fatal("copy_string(): out of memory"); strcpy(new, s); return new; } void dump_image(char *p); cell pp_dump_image(cell x) { char *path = copy_string(string(cadr(x))); FILE *f; f = fopen(string(cadr(x)), "r"); if (f != NULL) { fclose(f); return error("dump-image: file exists", cadr(x)); } dump_image(path); free(path); return UNSPECIFIC; } cell pp_delete_file(cell x) { if (remove(string(cadr(x))) < 0) error("delete-file: file does not exist", cadr(x)); return UNSPECIFIC; } cell pp_error(cell x) { return error(string(cadr(x)), length(x) > 2? caddr(x): NOEXPR); } cell pp_file_exists_p(cell x) { FILE *f; f = fopen(string(cadr(x)), "r"); if (f == NULL) return FALSE; fclose(f); return TRUE; } cell gensym(char *prefix) { static long g = 0; char s[200]; do { sprintf(s, "%s%ld", prefix, g); g++; } while (find_symbol(s) != NIL); return symbol_ref(s); } cell pp_gensym(cell x) { char pre[101]; int k; if (cdr(x) == NIL) { strcpy(pre, "g"); k = 1; } else if (string_p(cadr(x))) { memcpy(pre, string(cadr(x)), 100); k = string_len(cadr(x)); } else if (symbol_p(cadr(x))) { memcpy(pre, symbol_name(cadr(x)), 100); k = symbol_len(cadr(x)); } else return error("gensym: expected string or symbol, got", cadr(x)); if (k > 100) return error("gensym: prefix too long", cadr(x)); pre[100] = 0; return gensym(pre); } cell expand_syntax(cell x); cell pp_macro_expand(cell x) { x = cadr(x); save(x); x = expand_syntax(x); unsave(1); return x; } cell expand_syntax_1(cell x); cell pp_macro_expand_1(cell x) { x = cadr(x); save(x); x = expand_syntax_1(x); unsave(1); return x; } cell pp_reverse_b(cell x) { cell n, m, h; m = NIL; n = cadr(x); while (n != NIL) { if (constant_p(n)) return error("reverse!: immutable object", n); if (!pair_p(n)) return error("reverse!: expected list, got", cadr(x)); h = cdr(n); cdr(n) = m; m = n; n = h; } return m; } cell pp_set_input_port_b(cell x) { Input_port = port_no(cadr(x)); return UNSPECIFIC; } cell pp_set_output_port_b(cell x) { Output_port = port_no(cadr(x)); return UNSPECIFIC; } cell pp_stats(cell x) { cell n, m; int o_run_stats; gcv(); /* start from a known state */ reset_counter(&Reductions); reset_counter(&Conses); reset_counter(&Nodes); reset_counter(&Collections); o_run_stats = Run_stats; Run_stats = 1; Cons_stats = 0; n = eval(cadr(x)); save(n); Run_stats = o_run_stats; n = counter_to_list(&Collections); n = cons(n, NIL); save(n); car(Stack) = n; m = counter_to_list(&Nodes); n = cons(m, n); car(Stack) = n; m = counter_to_list(&Conses); n = cons(m, n); car(Stack) = n; m = counter_to_list(&Reductions); n = cons(m, n); n = cons(unsave(2), n); return n; } cell pp_symbols(cell x) { cell n, a, y, new; n = NIL; a = NIL; for (y=Symbols; y != NIL; y = cdr(y)) { if (n == NIL) { n = a = cons(car(y), NIL); save(n); } else { new = cons(car(y), NIL); cdr(a) = new; a = cdr(a); } } if (n != NIL) unsave(1); return n; } cell pp_trace(cell x) { cell n = Trace_list; if (cdr(x) == NIL) { n = Trace_list; Trace_list = NIL; } if (cddr(x) == NIL && cadr(x) == TRUE) { Trace_list = TRUE; } else { if (Trace_list == TRUE) Trace_list = NIL; x = cdr(x); while (x != NIL) { if (!symbol_p(car(x))) return error("trace: expected symbol, got", car(x)); Trace_list = cons(car(x), Trace_list); x = cdr(x); } } return n; } #ifdef unix cell pp_argv(cell x) { cell n; char **cl; if (Command_line == NULL || *Command_line == NULL) return FALSE; n = integer_value("argv", cadr(x)); cl = Command_line; for (; n--; cl++) if (*cl == NULL) return FALSE; return *cl == NULL? FALSE: make_string(*cl, strlen(*cl)); } cell pp_environ(cell x) { char *s; s = getenv(string(cadr(x))); if (s == NULL) return FALSE; return make_string(s, strlen(s)); } cell pp_system(cell x) { int r; r = system(string(cadr(x))); return make_integer(r >> 8); } #endif /* * Evaluator */ PRIM Primitives[] = { { "abs", pp_abs, 1, 1, { REA,___,___ } }, { "append2", pp_append2, 2, 2, { LST,___,___ } }, { "apply", pp_apply, 2, -1, { PRC,___,___ } }, { "assq", pp_assq, 2, 2, { ___,LST,___ } }, { "assv", pp_assv, 2, 2, { ___,LST,___ } }, { "bit-op", pp_bit_op, 3, -1, { INT,INT,INT } }, { "boolean?", pp_boolean_p, 1, 1, { ___,___,___ } }, { "caar", pp_caar, 1, 1, { PAI,___,___ } }, { "cadr", pp_cadr, 1, 1, { PAI,___,___ } }, { "cdar", pp_cdar, 1, 1, { PAI,___,___ } }, { "cddr", pp_cddr, 1, 1, { PAI,___,___ } }, { "caaar", pp_caaar, 1, 1, { PAI,___,___ } }, { "caadr", pp_caadr, 1, 1, { PAI,___,___ } }, { "cadar", pp_cadar, 1, 1, { PAI,___,___ } }, { "caddr", pp_caddr, 1, 1, { PAI,___,___ } }, { "call/cc", pp_call_cc, 1, 1, { PRC,___,___ } }, { "cdaar", pp_cdaar, 1, 1, { PAI,___,___ } }, { "cdadr", pp_cdadr, 1, 1, { PAI,___,___ } }, { "cddar", pp_cddar, 1, 1, { PAI,___,___ } }, { "cdddr", pp_cdddr, 1, 1, { PAI,___,___ } }, { "caaaar", pp_caaaar, 1, 1, { PAI,___,___ } }, { "caaadr", pp_caaadr, 1, 1, { PAI,___,___ } }, { "caadar", pp_caadar, 1, 1, { PAI,___,___ } }, { "caaddr", pp_caaddr, 1, 1, { PAI,___,___ } }, { "cadaar", pp_cadaar, 1, 1, { PAI,___,___ } }, { "cadadr", pp_cadadr, 1, 1, { PAI,___,___ } }, { "caddar", pp_caddar, 1, 1, { PAI,___,___ } }, { "cadddr", pp_cadddr, 1, 1, { PAI,___,___ } }, { "cdaaar", pp_cdaaar, 1, 1, { PAI,___,___ } }, { "cdaadr", pp_cdaadr, 1, 1, { PAI,___,___ } }, { "cdadar", pp_cdadar, 1, 1, { PAI,___,___ } }, { "cdaddr", pp_cdaddr, 1, 1, { PAI,___,___ } }, { "cddaar", pp_cddaar, 1, 1, { PAI,___,___ } }, { "cddadr", pp_cddadr, 1, 1, { PAI,___,___ } }, { "cdddar", pp_cdddar, 1, 1, { PAI,___,___ } }, { "cddddr", pp_cddddr, 1, 1, { PAI,___,___ } }, { "car", pp_car, 1, 1, { PAI,___,___ } }, { "cdr", pp_cdr, 1, 1, { PAI,___,___ } }, { "char?", pp_char_p, 1, 1, { ___,___,___ } }, { "char->integer", pp_char_to_integer, 1, 1, { CHR,___,___ } }, { "char-alphabetic?", pp_char_alphabetic_p, 1, 1, { CHR,___,___ } }, { "char-ci<=?", pp_char_ci_le_p, 2, -1, { CHR,___,___ } }, { "char-ci=?", pp_char_ci_ge_p, 2, -1, { CHR,___,___ } }, { "char-ci>?", pp_char_ci_gt_p, 2, -1, { CHR,___,___ } }, { "char-downcase", pp_char_downcase, 1, 1, { CHR,___,___ } }, { "char-lower-case?", pp_char_lower_case_p, 1, 1, { CHR,___,___ } }, { "char-numeric?", pp_char_numeric_p, 1, 1, { CHR,___,___ } }, { "char-upcase", pp_char_upcase, 1, 1, { CHR,___,___ } }, { "char-upper-case?", pp_char_upper_case_p, 1, 1, { CHR,___,___ } }, { "char-whitespace?", pp_char_whitespace_p, 1, 1, { CHR,___,___ } }, { "char<=?", pp_char_le_p, 2, -1, { CHR,___,___ } }, { "char=?", pp_char_ge_p, 2, -1, { CHR,___,___ } }, { "char>?", pp_char_gt_p, 2, -1, { CHR,___,___ } }, { "close-input-port", pp_close_input_port, 1, 1, { INP,___,___ } }, { "close-output-port", pp_close_output_port, 1, 1, { OUP,___,___ } }, { "cons", pp_cons, 2, 2, { ___,___,___ } }, { "current-input-port", pp_current_input_port, 0, 0, { ___,___,___ } }, { "current-output-port", pp_current_output_port, 0, 0, { ___,___,___ } }, { "delete-file", pp_delete_file, 1, 1, { STR,___,___ } }, { "display", pp_display, 1, 2, { ___,OUP,___ } }, { "dump-image", pp_dump_image, 1, 1, { STR,___,___ } }, { "eof-object?", pp_eof_object_p, 1, 1, { ___,___,___ } }, { "eq?", pp_eq_p, 2, 2, { ___,___,___ } }, { "=", pp_equal, 2, -1, { REA,___,___ } }, { "eqv?", pp_eqv_p, 2, 2, { ___,___,___ } }, { "even?", pp_even_p, 1, 1, { REA,___,___ } }, { "error", pp_error, 1, 2, { STR,___,___ } }, { "file-exists?", pp_file_exists_p, 1, 1, { STR,___,___ } }, { "gensym", pp_gensym, 0, 1, { ___,___,___ } }, { ">", pp_greater, 2, -1, { REA,___,___ } }, { ">=", pp_greater_equal, 2, -1, { REA,___,___ } }, { "input-port?", pp_input_port_p, 1, 1, { ___,___,___ } }, { "integer?", pp_integer_p, 1, 1, { ___,___,___ } }, { "integer->char", pp_integer_to_char, 1, 1, { INT,___,___ } }, { "length", pp_length, 1, 1, { LST,___,___ } }, { "<", pp_less, 2, -1, { REA,___,___ } }, { "<=", pp_less_equal, 2, -1, { REA,___,___ } }, { "list", pp_list, 0, -1, { ___,___,___ } }, { "list->string", pp_list_to_string, 1, 1, { LST,___,___ } }, { "list->vector", pp_list_to_vector, 1, 1, { LST,___,___ } }, { "list-tail", pp_list_tail, 2, 2, { LST,INT,___ } }, { "load", pp_load, 1, 1, { STR,___,___ } }, { "macro-expand", pp_macro_expand, 1, 1, { ___,___,___ } }, { "macro-expand-1", pp_macro_expand_1, 1, 1, { ___,___,___ } }, { "make-string", pp_make_string, 1, 2, { INT,CHR,___ } }, { "make-vector", pp_make_vector, 1, 2, { INT,___,___ } }, { "max", pp_max, 1, -1, { REA,___,___ } }, { "memq", pp_memq, 2, 2, { ___,LST,___ } }, { "memv", pp_memv, 2, 2, { ___,LST,___ } }, { "min", pp_min, 1, -1, { REA,___,___ } }, { "-", pp_minus, 1, -1, { REA,___,___ } }, { "negative?", pp_negative_p, 1, 1, { REA,___,___ } }, { "not", pp_not, 1, 1, { ___,___,___ } }, { "null?", pp_null_p, 1, 1, { ___,___,___ } }, { "odd?", pp_odd_p, 1, 1, { REA,___,___ } }, { "open-input-file", pp_open_input_file, 1, 1, { STR,___,___ } }, { "open-output-file", pp_open_output_file, 1, 1, { STR,___,___ } }, { "output-port?", pp_output_port_p, 1, 1, { ___,___,___ } }, { "pair?", pp_pair_p, 1, 1, { ___,___,___ } }, { "peek-char", pp_peek_char, 0, 1, { INP,___,___ } }, { "+", pp_plus, 0, -1, { REA,___,___ } }, { "positive?", pp_positive_p, 1, 1, { REA,___,___ } }, { "procedure?", pp_procedure_p, 1, 1, { ___,___,___ } }, { "quotient", pp_quotient, 2, 2, { REA,REA,___ } }, { "read", pp_read, 0, 1, { INP,___,___ } }, { "read-char", pp_read_char, 0, 1, { INP,___,___ } }, { "remainder", pp_remainder, 2, 2, { REA,REA,___ } }, { "reverse", pp_reverse, 1, 1, { LST,___,___ } }, { "reverse!", pp_reverse_b, 1, 1, { LST,___,___ } }, { "set-car!", pp_set_car_b, 2, 2, { PAI,___,___ } }, { "set-cdr!", pp_set_cdr_b, 2, 2, { PAI,___,___ } }, { "set-input-port!", pp_set_input_port_b, 1, 1, { INP,___,___ } }, { "set-output-port!", pp_set_output_port_b, 1, 1, { OUP,___,___ } }, { "stats", pp_stats, 1, 1, { ___,___,___ } }, { "string", pp_string, 0, -1, { CHR,___,___ } }, { "string->list", pp_string_to_list, 1, 1, { STR,___,___ } }, { "string->symbol", pp_string_to_symbol, 1, 1, { STR,___,___ } }, { "string-append", pp_string_append, 0, -1, { STR,___,___ } }, { "string-copy", pp_string_copy, 1, 1, { STR,___,___ } }, { "string-fill!", pp_string_fill_b, 2, 2, { STR,CHR,___ } }, { "string-length", pp_string_length, 1, 1, { STR,___,___ } }, { "string-ref", pp_string_ref, 2, 2, { STR,INT,___ } }, { "string-set!", pp_string_set_b, 3, 3, { STR,INT,CHR } }, { "string-ci<=?", pp_string_ci_le_p, 2, -1, { STR,___,___ } }, { "string-ci=?", pp_string_ci_ge_p, 2, -1, { STR,___,___ } }, { "string-ci>?", pp_string_ci_gt_p, 2, -1, { STR,___,___ } }, { "string<=?", pp_string_le_p, 2, -1, { STR,___,___ } }, { "string=?", pp_string_ge_p, 2, -1, { STR,___,___ } }, { "string>?", pp_string_gt_p, 2, -1, { STR,___,___ } }, { "string?", pp_string_p, 1, 1, { ___,___,___ } }, { "substring", pp_substring, 3, 3, { STR,INT,INT } }, { "symbol?", pp_symbol_p, 1, 1, { ___,___,___ } }, { "symbol->string", pp_symbol_to_string, 1, 1, { SYM,___,___ } }, { "symbols", pp_symbols, 0, 0, { ___,___,___ } }, { "*", pp_times, 0, -1, { REA,___,___ } }, { "trace", pp_trace, 0, -1, { ___,___,___ } }, { "unquote", pp_unquote, 1, 1, { ___,___,___ } }, { "unquote-splicing", pp_unquote_splicing, 1, 1, { ___,___,___ } }, { "vector", pp_vector, 0, -1, { ___,___,___ } }, { "vector-append", pp_vector_append, 0, -1, { VEC,___,___ } }, { "vector-copy", pp_vector_copy, 1, -1, { VEC,INT,INT } }, { "vector-fill!", pp_vector_fill_b, 2, 2, { VEC,___,___ } }, { "vector-length", pp_vector_length, 1, 1, { VEC,___,___ } }, { "vector-set!", pp_vector_set_b, 3, 3, { VEC,INT,___ } }, { "vector-ref", pp_vector_ref, 2, 2, { VEC,INT,___ } }, { "vector->list", pp_vector_to_list, 1, 1, { VEC,___,___ } }, { "vector?", pp_vector_p, 1, 1, { ___,___,___ } }, { "write", pp_write, 1, 2, { ___,OUP,___ } }, { "write-char", pp_write_char, 1, 2, { CHR,OUP,___ } }, { "zero?", pp_zero_p, 1, 1, { REA,___,___ } }, #ifdef REALNUM { "/", pp_divide, 1, -1, { REA,___,___ } }, { "exact->inexact", pp_exact_to_inexact, 1, 1, { REA,___,___ } }, { "exact?", pp_exact_p, 1, 1, { REA,___,___ } }, { "exponent", pp_exponent, 1, 1, { REA,___,___ } }, { "floor", pp_floor, 1, 1, { REA,___,___ } }, { "inexact->exact", pp_inexact_to_exact, 1, 1, { REA,___,___ } }, { "inexact?", pp_inexact_p, 1, 1, { REA,___,___ } }, { "mantissa", pp_mantissa, 1, 1, { REA,___,___ } }, { "real?", pp_real_p, 1, 1, { ___,___,___ } }, #endif /* REALNUM */ #ifdef unix { "argv", pp_argv, 1, 1, { INT,___,___ } }, { "environ", pp_environ, 1, 1, { STR,___,___ } }, { "system", pp_system, 1, 1, { STR,___,___ } }, #endif { NULL } }; cell expected(cell who, char *what, cell got) { char msg[100]; PRIM *p; p = (PRIM *) cadr(who); sprintf(msg, "%s: expected %s, got", p->name, what); return error(msg, got); } cell apply_primitive(cell x) { PRIM *p; cell a; int k, na, i; p = (PRIM *) cadar(x); k = length(x); if (k-1 < p->min_args) return too_few_args(x); if (k-1 > p->max_args && p->max_args >= 0) return too_many_args(x); a = cdr(x); na = p->max_args < 0? p->min_args: p->max_args; if (na > k-1) na = k-1; for (i=1; i<=na; i++) { switch (p->arg_types[i-1]) { case T_NONE: break; case T_BOOLEAN: if (!boolean_p(car(a))) return expected(car(x), "boolean", car(a)); break; case T_CHAR: if (!char_p(car(a))) return expected(car(x), "char", car(a)); break; case T_INPUT_PORT: if (!input_port_p(car(a))) return expected(car(x), "input-port", car(a)); break; case T_INTEGER: if (!integer_p(car(a))) return expected(car(x), "integer", car(a)); break; case T_OUTPUT_PORT: if (!output_port_p(car(a))) return expected(car(x), "output-port", car(a)); break; case T_PAIR: if (atom_p(car(a))) return expected(car(x), "pair", car(a)); break; case T_PAIR_OR_NIL: if (car(a) != NIL && atom_p(car(a))) return expected(car(x), "list", car(a)); break; case T_PROCEDURE: if ( !procedure_p(car(a)) && !primitive_p(car(a)) && !continuation_p(car(a)) ) return expected(car(x), "procedure", car(a)); break; case T_REAL: if (!integer_p(car(a)) && !real_p(car(a))) return expected(car(x), "number", car(a)); break; case T_STRING: if (!string_p(car(a))) return expected(car(x), "string", car(a)); break; case T_SYMBOL: if (!symbol_p(car(a))) return expected(car(x), "symbol", car(a)); break; case T_VECTOR: if (!vector_p(car(a))) return expected(car(x), "vector", car(a)); break; } a = cdr(a); } return (*p->handler)(x); } int uses_transformer_p(cell x) { cell y; if (atom_p(x) || car(x) == S_quote) return 0; if (pair_p(x) && symbol_p(car(x))) { y = lookup(car(x), Environment, 0); if (y != NIL && syntax_p(binding_value(y))) return 1; } while (pair_p(x)) { if (uses_transformer_p(car(x))) return 1; x = cdr(x); } return 0; } cell _eval(cell x, int cbn); cell expand_syntax_1(cell x) { cell y, m, n, a, app; if (Error_flag || atom_p(x) || car(x) == S_quote) return x; if (symbol_p(car(x))) { y = lookup(car(x), Environment, 0); if (y != NIL && syntax_p(binding_value(y))) { save(x); app = cons(cdr(binding_value(y)), cdr(x)); unsave(1); return _eval(app, 1); } } /* * If DEFINE-SYNTAX is followed by (MACRO-NAME ...) * unbind the MACRO-NAME first to avoid erroneous * expansion. */ if ( car(x) == S_define_syntax && cdr(x) != NIL && pair_p(cadr(x)) ) { m = lookup(caadr(x), Environment, 0); if (m != NIL) binding_value(m) = UNDEFINED; } n = a = NIL; save(n); while (pair_p(x)) { m = cons(expand_syntax_1(car(x)), NIL); if (n == NIL) { n = m; car(Stack) = n; a = n; } else { cdr(a) = m; a = cdr(a); } x = cdr(x); } cdr(a) = x; unsave(1); return n; } cell expand_syntax(cell x) { if (Error_flag || atom_p(x) || car(x) == S_quote) return x; save(x); while (!Error_flag) { if (!uses_transformer_p(x)) break; x = expand_syntax_1(x); car(Stack) = x; } unsave(1); return x; } cell restore_state(void) { cell v; if (State_stack == NIL) fatal("restore_state: stack underflow"); v = car(State_stack); State_stack = cdr(State_stack); return v; } cell bind_arguments(cell n, int tail) { cell p, v, a; cell rib; save(Environment); p = car(n); a = cdr(n); v = cadr(p); Environment = cdddr(p); rib = NIL; save(rib); while (pair_p(v)) { if (atom_p(a)) { unsave(1); return too_few_args(n); } Tmp = make_binding(car(v), car(a)); rib = cons(Tmp, rib); car(Stack) = rib; v = cdr(v); a = cdr(a); } if (symbol_p(v)) { Tmp = make_binding(v, a); rib = cons(Tmp, rib); car(Stack) = rib; } else if (a != NIL) { unsave(1); return too_many_args(n); } Tmp = NIL; unsave(1); Environment = make_env(rib, Environment); return UNSPECIFIC; } int tail_call(void) { if (State_stack == NIL || car(State_stack) != EV_BETA) return 0; Tmp = unsave(1); Environment = car(Stack); unsave(2); restore_state(); save(Tmp); Tmp = NIL; return 1; } void trace(cell name, cell expr) { if (Error_flag) return; if ( Trace_list == TRUE || memqv("trace", 0, name, Trace_list) != FALSE ) { pr("+ "); print_form(cons(name, cdr(expr))); nl(); } } cell _eval(cell x, int cbn) { cell m2, /* Root of result list */ a, /* Used to append to result */ rib; /* Temp storage for args */ int s, /* Current state */ c; /* Continue */ cell name; /* Name of procedure to apply */ save(x); save(State_stack); save(Stack_bottom); Stack_bottom = Stack; s = EV_ATOM; c = 0; while (!Error_flag) { if (Run_stats) count(&Reductions); if (symbol_p(x)) { /* Symbol -> Value */ if (cbn) { Acc = x; cbn = 0; } else { Acc = lookup(x, Environment, 1); if (Error_flag) break; Acc = box_value(Acc); } } else if (auto_quoting_p(x) || cbn == 2) { Acc = x; /* Object -> Object */ cbn = 0; } else { /* (...) -> Value */ /* * This block is used to DESCEND into lists. * The following structure is saved on the * Stack: RIB = (args append result source) * The current s is saved on the State_stack. */ Acc = x; x = car(x); save_state(s); /* Check call-by-name built-ins and flag */ if (special_p(x) || cbn) { cbn = 0; rib = cons(Acc, Acc); /* result/source */ rib = cons(NIL, rib); /* append */ rib = cons(NIL, rib); /* args */ if (!proper_list_p(Acc)) error("syntax error", Acc); x = NIL; } else { Tmp = cons(NIL, NIL); rib = cons(Tmp, Acc); /* result/source */ rib = cons(Tmp, rib); /* append */ rib = cons(cdr(Acc), rib); /* args */ Tmp = NIL; x = car(Acc); } save(rib); s = EV_ARGS; continue; } /* * The following loop is used to ASCEND back to the * root of a list, thereby performing BETA REDUCTION. */ while (!Error_flag) if (s == EV_BETA) { /* Finish BETA reduction */ Environment = unsave(1); unsave(1); /* source expression */ s = restore_state(); } else if (s == EV_ARGS) { /* append to list, reduce */ rib = car(Stack); x = rib_args(rib); a = rib_append(rib); m2 = rib_result(rib); if (a != NIL) /* Append new member */ car(a) = Acc; if (x == NIL) { /* End of list */ Acc = m2; /* Remember name of caller */ name = car(rib_source(rib)); if (Trace_list != NIL) trace(name, Acc); if (primitive_p(car(Acc))) { if ((PRIM *) cadar(Acc) == Apply_magic) c = cbn = 1; if ((PRIM *) cadar(Acc) == Call_magic) c = cbn = 1; Cons_stats = 1; Acc = x = apply_primitive(Acc); Cons_stats = 0; } else if (special_p(car(Acc))) { Acc = x = apply_special(Acc, &c, &s); } else if (procedure_p(car(Acc))) { name = symbol_p(name)? name: NIL; Called_procedures[Proc_ptr] = name; Proc_ptr++; if (Proc_ptr >= Proc_max) Proc_ptr = 0; bind_arguments(Acc, tail_call()); x = caddar(Acc); c = 2; s = EV_BETA; } else if (continuation_p(car(Acc))) { Acc = resume(Acc); } else { error("application of non-procedure", name); x = NIL; } if (c != 2) { unsave(1); /* drop source expr */ s = restore_state(); } /* Leave the ASCENDING loop and descend */ /* once more into X. */ if (c) break; } else if (atom_p(x)) { error("syntax error", rib_source(rib)); x = NIL; break; } else { /* X =/= NIL: append to list */ /* Create space for next argument */ Acc = cons(NIL, NIL); cdr(a) = Acc; rib_append(rib) = cdr(a); rib_args(rib) = cdr(x); x = car(x); /* evaluate next member */ break; } } else if (s == EV_IF_PRED) { x = unsave(1); unsave(1); /* source expression */ s = restore_state(); if (Acc != FALSE) x = cadr(x); else x = caddr(x); c = 1; break; } else if (s == EV_AND || s == EV_OR) { Stack = cons(cdar(Stack), cdr(Stack)); if ( (Acc == FALSE && s == EV_AND) || (Acc != FALSE && s == EV_OR) || car(Stack) == NIL ) { unsave(2); /* state, source expr */ s = restore_state(); x = Acc; cbn = 2; } else if (cdar(Stack) == NIL) { x = caar(Stack); unsave(2); /* state, source expr */ s = restore_state(); } else { x = caar(Stack); } c = 1; break; } else if (s == EV_COND) { char cond_err[] = "cond: invalid syntax"; if (Acc != FALSE) { x = cdaar(Stack); if (x == NIL) { x = quote(Acc, S_quote); } else if (pair_p(cdr(x))) { if (car(x) == S_arrow) { if (cddr(x) != NIL) error(cond_err, x); Acc = quote(Acc, S_quote); Acc = cons(Acc, NIL); Acc = x = cons(cadr(x), Acc); } else { Acc = x = cons(S_begin, x); } } else { x = car(x); } unsave(2); /* state, source expr */ s = restore_state(); } else if (cdar(Stack) == NIL) { unsave(2); /* state, source expr */ s = restore_state(); x = UNSPECIFIC; } else { Stack = cons(cdar(Stack), cdr(Stack)); x = caaar(Stack); if (x == S_else && cdar(Stack) == NIL) x = TRUE; } c = 1; break; } else if (s == EV_BEGIN) { Stack = cons(cdar(Stack), cdr(Stack)); if (cdar(Stack) == NIL) { x = caar(Stack); unsave(2); /* state, source expr */ s = restore_state(); } else { x = caar(Stack); } c = 1; break; } else if (s == EV_SET_VAL || s == EV_MACRO) { char err[] = "define-syntax: expected procedure, got"; if (s == EV_MACRO) { if (procedure_p(Acc)) { Acc = new_atom(T_SYNTAX, Acc); } if (syntax_p(Acc)) { /* Acc = Acc; */ } else { error(err, Acc); break; } } x = unsave(1); unsave(1); /* source expression */ s = restore_state(); box_value(x) = Acc; Acc = x = UNSPECIFIC; c = 0; break; } else { /* s == EV_ATOM */ break; } if (c) { /* Continue evaluation if requested */ c = 0; continue; } if (Stack == Stack_bottom) break; } Stack = Stack_bottom; Stack_bottom = unsave(1); State_stack = unsave(1); unsave(1); return Acc; /* Return the evaluated expr */ } void reset_calltrace(void) { int i; for (i=0; i "); flush(); } Program = xread(); if (Program == END_OF_FILE) break; if (!Error_flag) n = eval(Program); if (!Error_flag && !unspecific_p(n)) { print_form(n); pr("\n"); box_value(S_latest) = n; } if (Error_flag) Environment = car(sane_env); } unsave(1); pr("\n"); } /* * Startup and Initialization */ /* Variables to dump to image file */ cell *Image_vars[] = { &Free_list, &Free_vecs, &Symbols, &Environment, &S_arrow, &S_else, &S_extensions, &S_latest, &S_library_path, &S_loading, &S_quasiquote, &S_quote, &S_unquote, &S_unquote_splicing, &S_and, &S_begin, &S_cond, &S_define, &S_define_syntax, &S_if, &S_lambda, &S_or, &S_quote, &S_set_b, NULL }; struct magic { char id[2]; /* "S9" */ char version[10]; /* "yyyy-mm-dd" */ char cell_size[1]; /* size + '0' */ char mantissa_size[1]; /* size + '0' */ char _pad[2]; /* "__" */ char byte_order[8]; /* e.g. "4321" */ char binary_id[8]; /* see code */ }; void dump_image(char *p) { FILE *f; cell n, **v; int i, k; struct magic m; char buf[100]; f = fopen(p, "wb"); if (f == NULL) { error("cannot create image file", make_string(p, (int) strlen(p))); return; } memset(&m, '_', sizeof(m)); strncpy(m.id, "S9", sizeof(m.id)); strncpy(m.version, VERSION, sizeof(m.version)); m.cell_size[0] = sizeof(cell)+'0'; m.mantissa_size[0] = MANTISSA_SEGMENTS+'0'; n = 0x31323334L; memcpy(m.byte_order, &n, sizeof(n)>8? 8: sizeof(n)); n = (cell) &Primitives; memcpy(m.binary_id, &n, sizeof(n)>8? 8: sizeof(n)); fwrite(&m, sizeof(m), 1, f); i = Cons_pool_size; fwrite(&i, sizeof(int), 1, f); i = Vec_pool_size; fwrite(&i, sizeof(int), 1, f); v = Image_vars; i = 0; while (v[i]) { fwrite(v[i], sizeof(cell), 1, f); i++; } if ( fwrite(Car, 1, Cons_pool_size*sizeof(cell), f) != Cons_pool_size*sizeof(cell) || fwrite(Cdr, 1, Cons_pool_size*sizeof(cell), f) != Cons_pool_size*sizeof(cell) || fwrite(Tag, 1, Cons_pool_size, f) != Cons_pool_size || fwrite(Vectors, 1, Vec_pool_size*sizeof(cell), f) != Vec_pool_size*sizeof(cell) ) { fclose(f); error("image dump failed", NOEXPR); return; } fclose(f); k = gc(); if (!Quiet_mode) { sprintf(buf, "image dumped: %d nodes used, %d free", Cons_pool_size-k, k); pr(buf); nl(); } } int load_image(char *p) { FILE *f; cell n, **v; int i; struct magic m; int ok = 1; int image_nodes, image_vcells; cell name; name = make_string(p, (int) strlen(p)); f = fopen(p, "rb"); if (f == NULL) return -1; fread(&m, sizeof(m), 1, f); if (memcmp(m.id, "S9", 2)) { error("error in image file (magic match failed)", name); ok = 0; } if (memcmp(m.version, VERSION, 10)) { error("error in image file (wrong version)", name); ok = 0; } if (m.cell_size[0]-'0' != sizeof(cell)) { error("error in image file (wrong cell size)", name); ok = 0; } if (m.mantissa_size[0]-'0' != MANTISSA_SEGMENTS) { error("error in image file (wrong mantissa size)", name); ok = 0; } memcpy(&n, m.byte_order, sizeof(cell)); if (n != 0x31323334L) { error("error in image file (wrong architecture)", name); ok = 0; } memcpy(&n, m.binary_id, sizeof(cell)); if (n != (cell) &Primitives) { error("error in image file (wrong interpreter)", name); ok = 0; } memset(Tag, 0, Cons_pool_size); fread(&image_nodes, sizeof(int), 1, f); fread(&image_vcells, sizeof(int), 1, f); while (image_nodes > Cons_pool_size) { if ( Memory_limit_kn && Cons_pool_size + Cons_segment_size > Memory_limit_kn ) { error("image too big (too many conses)", NOEXPR); ok = 0; break; } new_cons_segment(); } while (image_vcells > Vec_pool_size) { if ( Memory_limit_kn && Vec_pool_size + Vec_segment_size > Memory_limit_kn ) { error("image too big (too many vcells)", NOEXPR); ok = 0; break; } new_vec_segment(); } v = Image_vars; i = 0; while (v[i]) { fread(v[i], sizeof(cell), 1, f); i++; } if ( ok && (fread(Car, 1, image_nodes*sizeof(cell), f) != image_nodes*sizeof(cell) || fread(Cdr, 1, image_nodes*sizeof(cell), f) != image_nodes*sizeof(cell) || fread(Tag, 1, image_nodes, f) != image_nodes || fread(Vectors, 1, image_vcells*sizeof(cell), f) != image_vcells*sizeof(cell) || fgetc(f) != EOF) ) { error("error in image file (wrong size)", NOEXPR); ok = 1; } fclose(f); if (Error_flag) fatal("unusable image"); return 0; } cell get_library_path(void) { char *s; s = getenv("S9FES_LIBRARY_PATH"); if (s == NULL) s = DEFAULT_LIBRARY_PATH; return make_string(s, (int) strlen(s)); } char *libname(char *argv0) { char *name; if (argv0 == NULL || argv0[0] == 0) argv0 = "s9"; name = strrchr(argv0, '/'); name = name? &name[1]: argv0; return name; } void load_library(char *argv0) { char *path, buf[256], *p; char libdir[240], libfile[256]; char *home, *image; cell new; image = libname(argv0); path = copy_string(string(box_value(S_library_path))); home = getenv("HOME"); if (home == NULL) home = "."; p = strtok(path, ":"); while (p != NULL) { if (p[0] == '~') { if (strlen(p) + strlen(home) >= sizeof(libdir)-1) fatal("load_library: path too long"); sprintf(libdir, "%s%s", home, &p[1]); } else { if (strlen(p) >= sizeof(libdir)-1) fatal("load_library: path too long"); strcpy(libdir, p); } if (strlen(image) + strlen(libdir) + strlen(".image") >= sizeof(libfile)-1 ) fatal("load_library: path too long"); sprintf(libfile, "%s/%s.image", libdir, image); if (strcmp(image, "-") && load_image(libfile) == 0) { free(path); /* *library-path* is overwritten by load_image() */ new = get_library_path(); box_value(S_library_path) = new; return; } if (strlen(image) + strlen(libdir) + strlen(".scm") >= sizeof(libfile)-1 ) fatal("load_library: path too long"); sprintf(libfile, "%s/%s.scm", libdir, !strcmp(image, "-")? "s9": image); if (load(libfile) == 0) { free(path); return; } p = strtok(NULL, ":"); } sprintf(buf, "found neither \"%s.image\" nor \"%s.scm\"", image, image); fatal(buf); } void load_rc(void) { char rcpath[256]; char rcfile[] = "/.s9fes/rc"; char *home; home = getenv("HOME"); if (home == NULL) return; if (strlen(home) + strlen(rcfile) + 1 >= sizeof(rcpath)-1) fatal("path too long in HOME"); sprintf(rcpath, "%s/%s", home, rcfile); load(rcpath); } void add_primitives(char *name, PRIM *p) { cell v, n, new; int i; if (name) { n = symbol_ref(name); new = cons(n, box_value(S_extensions)); box_value(S_extensions) = new; } for (i=0; p && p && p[i].name; i++) { if (Apply_magic == NULL && !strcmp(p[i].name, "apply")) Apply_magic = &p[i]; if (Call_magic == NULL && !strcmp(p[i].name, "call/cc")) Call_magic = &p[i]; v = symbol_ref(p[i].name); n = new_atom((cell) &p[i], NIL); n = new_atom(T_PRIMITIVE, n); Environment = extend(v, n, Environment); } } /* Extension prototypes; add your own here. */ void curs_init(void); void sys_init(void); void make_initial_env(void) { cell new; Environment = cons(NIL, NIL); Environment = extend(symbol_ref("**"), NIL, Environment); S_latest = cadr(Environment); Environment = extend(symbol_ref("*extensions*"), NIL, Environment); S_extensions = cadr(Environment); Environment = extend(symbol_ref("*library-path*"), NIL, Environment); S_library_path = cadr(Environment); new = get_library_path(); box_value(S_library_path) = new; Environment = extend(symbol_ref("*loading*"), FALSE, Environment); S_loading = cadr(Environment); Apply_magic = NULL; Call_magic = NULL; add_primitives(NULL, Primitives); EXTENSIONS; #ifdef REALNUM add_primitives("realnums", NULL); #endif Environment = cons(Environment, NIL); Program = TRUE; /* or rehash() will not work */ rehash(car(Environment)); } void init(void) { int i; for (i=2; i"); S_and = symbol_ref("and"); S_begin = symbol_ref("begin"); S_cond = symbol_ref("cond"); S_define = symbol_ref("define"); S_define_syntax = symbol_ref("define-syntax"); S_else = symbol_ref("else"); S_if = symbol_ref("if"); S_lambda = symbol_ref("lambda"); S_or = symbol_ref("or"); S_quasiquote = symbol_ref("quasiquote"); S_quote = symbol_ref("quote"); S_set_b = symbol_ref("set!"); S_unquote = symbol_ref("unquote"); S_unquote_splicing = symbol_ref("unquote-splicing"); make_initial_env(); reset_calltrace(); } void init_extensions(void) { cell e, n; char initproc[TOKEN_LENGTH+2]; char *s; char *s9 = "s9"; e = box_value(S_extensions); while (s9 || e != NIL) { s = s9? s9: string(car(e)); if (strlen(s)*2+1 >= TOKEN_LENGTH) fatal("init_extension(): procedure name too long"); sprintf(initproc, "%s:%s", s, s); n = find_symbol(initproc); if (n != NIL) { n = cons(n, NIL); eval(n); } e = s9? e: cdr(e); s9 = NULL; } } void usage(int quit) { pr("Usage: s9 [-h?] [-i name] [-gnqv] [-f prog [args]] [-m size[m]]"); nl(); pr(" [-l prog] [-t count] [-d image] [-- [args]]"); nl(); if (quit) bye(1); } void long_usage() { nl(); usage(0); nl(); pr("-h display this summary (also -?)"); nl(); pr("-i name base name of image file (must be first option!)"); nl(); pr("-i - ignore image, load s9.scm instead"); nl(); pr("-d file dump heap image to file and exit"); nl(); pr("-f file [args] run program and exit (implies -q)"); nl(); pr("-g print GC summaries (-gg = more)"); nl(); pr("-l file load program (may be repeated)"); nl(); pr("-n do not load $HOME/.s9fes/rc"); nl(); pr("-m n[m] set memory limit to nK (or nM) nodes"); nl(); pr("-q be quiet (no banner, no prompt, exit on errors)"); nl(); pr("-t n list up to N procedures in call traces"); nl(); pr("-v print version and exit"); nl(); pr("-- [args] pass subsequent arguments to program"); nl(); nl(); } void version_info(char *name) { char buf[100]; cell x; nl(); pr("Scheme 9 from Empty Space by Nils M Holm"); nl(); nl(); pr("version: "); pr(VERSION); #ifdef unix pr(" (unix)"); #else #ifdef plan9 pr(" (plan 9)"); #else pr(" (unknown)"); #endif #endif nl(); pr("heap image: "); if (!strcmp(name, "-")) pr("n/a"); else { pr(name); pr(".image"); } nl(); pr("library path: "); pr(string(box_value(S_library_path))); nl(); pr("memory limit: "); if (Memory_limit_kn) { sprintf(buf, "%ld", Memory_limit_kn / 1024); pr(buf); pr("K nodes"); nl(); } else { pr("none"); nl(); } pr("extensions: "); if (box_value(S_extensions) == NIL) pr("-"); for (x = box_value(S_extensions); x != NIL; x = cdr(x)) { print_form(car(x)); if (cdr(x) != NIL) pr(" "); } nl(); #ifdef REALNUM pr("mantissa size: "); sprintf(buf, "%d", MANTISSA_SIZE); pr(buf); pr(" digits"); nl(); #endif nl(); pr("This program is in the public domain."); nl(); nl(); } long get_size_k(char *s) { int c; long n; c = s[strlen(s)-1]; n = atol(s); if (isdigit(c)) ; else if (c == 'M' || c == 'm') n *= 1024L; else usage(1); return n * 1024; } int main(int argc, char **argv) { int ignore_rc = 0; int run_script; char *argv0; if (argc > 1 && !strcmp(argv[1], "-i")) { if (argc < 2) { usage(1); bye(1); } argv += 2; } init(); signal(SIGQUIT, keyboard_quit); signal(SIGTERM, terminated); load_library(argv[0]); argv0 = *argv++; init_extensions(); while (*argv != NULL) { if (**argv != '-') break; (*argv)++; while (**argv) { switch (**argv) { case '-': Command_line = ++argv; break; case 'd': if (argv[1] == NULL) usage(1); dump_image(argv[1]); bye(Error_flag? 1: 0); break; case 'f': case 'l': if (argv[1] == NULL) usage(1); run_script = **argv == 'f'; if (run_script) { Quiet_mode = 1; Command_line = &argv[2]; } if (load(argv[1])) error("program file not found", make_string(argv[1], (int)strlen(argv[1]))); if (Error_flag) bye(1); if (run_script) bye(0); argv++; *argv = &(*argv)[strlen(*argv)]; break; case 'g': Verbose_GC++; (*argv)++; break; case 'n': ignore_rc = 1; (*argv)++; break; case 'm': if (argv[1] == NULL) usage(1); Memory_limit_kn = get_size_k(argv[1]); argv++; *argv += strlen(*argv); break; case 'q': Quiet_mode = 1; (*argv)++; break; case 't': if (argv[1] == NULL) usage(1); Proc_max = atoi(argv[1]); if (Proc_max > MAX_CALL_TRACE) Proc_max = MAX_CALL_TRACE; argv++; *argv += strlen(*argv); break; case 'v': version_info(argv0); bye(0); break; case 'h': case '?': long_usage(); bye(0); break; default: usage(1); break; } if (Command_line) break; } if (Command_line) break; argv++; } if (!Command_line && argv[0] != NULL) usage(1); if (!Quiet_mode) pr("Scheme 9 from Empty Space\n"); if (!ignore_rc) load_rc(); repl(); reset_tty(); return 0; } s9/mkfile000644 001751 001751 00000000241 11117443340 012206 0ustar00nmhnmh000000 000000 # mkfile for Plan 9 # By Nils M Holm, 2008 all:V: s9 s9.image s9: s9.8 8l -o s9 s9.8 s9.8: s9.c s9.h 8c -Dplan9 s9.c s9.image: s9 s9.scm ./s9 -d s9.image s9/s9.1000644 001751 001751 00000036754 12245077435 011466 0ustar00nmhnmh000000 000000 .\" S9(1) Manual Page .\" By Nils M Holm, 2007-2012 .ll 70 .lt 70 .de HD \" header 'sp 1v .tl 'S9(1)'Scheme 9 from Empty Space'S9(1)' 'sp 2v .. .de FO \" footer 'sp 2v .tl 'S9 Interpreter'Page %'S9(1)' 'bp .. .de B \fB\\$1\fP .. .de BR \fB\\$1\fP\\$2 .. .de IR \fI\\$1\fP\\$2 .. .de RB \\$1\fB\\$2\\fP .. .de I \fI\\$1\fP .. .de SH \" subheading .ne 5 .sp .in 0i .nf \fB\\$1\fP .fi .in 1i .. .wh 0 HD \" traps for header .wh -4 FO \" and footer .nh .sp .SH NAME .B "s9 - Scheme Interpreter .SH USAGE .B "s9 [-h?] [-i name] [-gnqv] [-m size[m]] [-f prog [args]] .B " [-l prog] [-t count] [-d image] [-- [args]] .SH "DESCRIPTION .B "Scheme 9 from Empty Space is an interpreter for R4RS Scheme with some additional procedures for accessing typical Unix system calls and Unix and Curses library functions (if compiled-in). The .B s9 command starts the interpreter. .SH "OPTIONS .B "-h or -? .in +4 Display a brief summary of options. .in -4 .B "-i name .in +4 Load alternative image file `\fIname\fP.image'. When no image file can be found, try to load `\fIname\fP.scm'. The file will be searched in the entire .I S9FES_LIBRARY_PATH (see below). When this option is used, it .B must be the first one of the s9 command. .br When `-' is specified as \fIname\fP, no heap image will be loaded, and the core library will be read from the source file `s9.scm'. .in -4 .B "-d file .in +4 Dump heap image to .I file and exit. .in -4 .B "-f program [arguments] .in +4 Run .I program and exit (implies -q). When there are any .IR arguments , they are passed to the .IR program , where they can be extracted using the .B command-line procedure. .in -4 .B "-g .in +4 Print GC summaries (\fB-gg\fP = more verbose). .in -4 .B "-n .in +4 Do not load .I $HOME/.s9fes/rc file, if any. .in -4 .B "-l program .in +4 Load .I program before entering the REPL or processing .BR -f (may be repeated). .in -4 .B "-m N[m] .in +4 Set memory limit to .I N kilo (or mega) nodes (\fB-m 0\fP means no limit; use with care!). .in -4 .B "-q .in +4 Be quiet: skip banners and prompts, exit on errors. .in -4 .B "-t count .in +4 Display .I count procedures at most in call traces. .in -4 .B -v .in +4 Display version and exit. .in -4 .B "-- [argument ...] .in +4 Arguments following .B -- are not interpreted by S9fES, but passed to the .B command-line procedure instead (requires the .B unix extension). .in -4 .SH "ONLINE HELP When the interpreter is running and the default heap image is loaded, just type \fB(help)\fP or \fB,h\fP to invoke the online help system. When the online help system is not loaded, you will have to run the following command first: .sp \fB(load-from-library "help.scm")\fP .SH "META COMMANDS In order to facilitate the invocation of frequently-used top-level procedures, .B s9 provides the following "meta commands" (they work only when entered directly at the .B s9 prompt): .sp .in +4 .nf \fB,a text\fP = (apropos "text") \fB,h text\fP = (help "text") \fB,l file\fP = (load-from-library "file") \fB,q \fP = (sys:exit) .fi .in -4 .sp The arguments of \fB,a\fP and \fB,h\fP are optional. .SH "ADDITIONS S9fES supports nestable block comments of the form .sp .in +4 .nf \fB#|\fP \fIcomment ...\fP \fB|#\fP. .fi .in -4 .sp Square brackets may be used in the places of parentheses: .sp .in +4 .nf \fB(cond [(foo) (bar)])\fP. .fi .in -4 .sp The same type of bracket must be used on both ends of a list. .sp These S9fES procedures are not in R4RS: .sp .ne 3 .B "(argv integer) ==> string | #f .in +4 Retrieve the value of the given command line argument. Return \fB#f\fP, if there are less than \fIinteger\fP+1 arguments. Arguments start at 0. .in -4 .sp .ne 3 .B "(bit-op integer1 integer2 integer3 ...) ==> integer | #f .in +4 Implement a variety of bitwise operations. See the .B bit-op help page for details. .in -4 .sp .ne 3 .B "(delete-file string) ==> unspecific .in +4 Delete the file specified in the .I string argument. If the file does not exist or cannot be deleted, report an error. .in -4 .sp .ne 3 .B "(dump-image string) ==> unspecific .in +4 Write a heap image to the file given in the .I string argument. If the file already exists, report an error. .in -4 .sp .ne 3 .B "(environ string) ==> string | #f .in +4 Retrieve the value of the given environment variable. Return \fB#f\fP, if the variable is undefined. .in -4 .sp .ne 3 .B "(error string) ==> undefined .br .B "(error string object) ==> undefined .in +4 Print an error message of the form .I "error: string: object and terminate program execution. .in -4 .sp .ne 3 .B "(exponent real) ==> integer .in +4 Extract the exponent part from a real number. .in -4 .sp .ne 3 .B "(file-exists? string) ==> boolean .in +4 Return .B "#t if the file specified in the .I string argument exists and otherwise \fB#f\fP. .in -4 .sp .ne 4 .B "(fold-left proc base list ...) ==> object .in +4 Combine the elements of the .IR list s using .IR proc . Combine elements left-associatively. .I Base is the leftmost element. .in -4 .sp .ne 4 .B "(fold-right proc base list ...) ==> object .in +4 Combine the elements of the .IR list s using .IR proc . Combine elements right-associatively. .I Base is the rightmost element. .in -4 .sp .B "(gensym) ==> symbol .br .B "(gensym symbol) ==> symbol .br .B "(gensym string) ==> symbol .in +4 Return a fresh symbol. When a .I string or .I symbol argument is given, use it as prefix for the fresh symbol. .in -4 .sp .ne 2 .B "(load-from-library string) ==> unspecific .in +4 Attempt to .B load the file .I string from each directory of .IR S9FES_LIBRARY_PATH . .in -4 .sp .ne 2 .B "(locate-file string) ==> string | #f .in +4 Search for the file .I string in each directory of .I S9FES_LIBRARY_PATH in sequence. When the file can be located, return its full path, else return \fB#f\fP. .in -4 .sp .ne 3 .B "(macro-expand object) ==> object .br .B "(macro-expand-1 object) ==> object .in +4 If .I object is a list resembling a macro application, return the expanded form, else return the object. .B Macro-expand-1 expands macros only once while .B macro-expand expands them recursively. .in -4 .sp .ne 3 .B "(mantissa real) ==> integer .in +4 Extract the mantissa part from a real number. .in -4 .sp .ne 2 .B "(print object ...) ==> unspecific .in +4 Write multiple .IR object s separated by spaces. .in -4 .sp .ne 2 .B "(require-extension name ...) ==> unspecific .in +4 Require the named extensions to be compiled-in. Signal an error if not all of the required extensions are present. .in -4 .sp .ne 2 .B "(reverse! list) ==> list .in +4 Reverse .I list destructively and return the reverse list. .in -4 .sp .ne 2 .B "(set-input-port! input-port) ==> unspecific .in +4 Destructively set the current input port. .in -4 .sp .ne 2 .B "(set-output-port! output-port) ==> unspecific .in +4 Destructively set the current output port. .in -4 .sp .ne 2 .B "(stats form) ==> form .in +4 Evaluate the given .I form and return a list containing its normal form plus a summary of the resources used to compute that normal form: .in +4 .sp .nf - reduction steps - conses allocated - total nodes allocated - garbage collections .fi .in -4 .sp Each resource count will be returned as a group of integers representing ones, thousands, millions, etc. Note that .I form must be quoted or it will be evaluated before passing it to .BR stats . .in -4 .sp .ne 2 .B "(symbols) ==> list .in +4 Return a list of all defined symbols. .in -4 .sp .ne 3 .B "(system string) ==> number .in +4 Run the given shell command and return its exit code. .in -4 .sp .ne 3 .B "(trace symbol ...) ==> list | #t .br .B "(trace #t) ==> list | #t .in +4 Trace the procedure or syntax object bound to the given .IR symbol s. When .B #t is passed to .BR trace , trace .I all procedures and syntax objects (\fIexpect lots of output!\fP). When no arguments are passed to it, disable tracing. .B Trace returns the symbols that were being traced before its invocation. .in -4 .sp .ne 3 .B "(vector-append vector ...) ==> vector .in +4 Return a fresh vector containing the concatenation of the given vectors. .in -4 .sp .ne 3 .B "(vector-copy vector) ==> vector .br .B "(vector-copy vector integer) ==> vector .br .B "(vector-copy vector integer1 integer2) ==> vector .br .B "(vector-copy vector integer1 integer2 object) ==> vector .in +4 Return a copy of the given vector. When .I integer1 is specified, skip the given number of elements. When .I integer2 is also specified, copy elements from .I integer1 up to, but not including, .IR integer2 . When .I integer2 exceeds the size of the original vector, add unspecific slots to the copy. When an .I object argument is given, fill extra slots with that argument. .in -4 .sp .ne 3 .B "(void) ==> unspecific .in +4 Return an unspecific value. .in -4 .sp Refer to the help pages for descriptions of the Scheme 9 extension procedures. .SH "SPECIAL VARIABLES These variables are predefined in the dynamic top-level scope of the interpreter. .sp .ne 2 .B "** (form) .in +4 The normal form of the expression most recently evaluated at the top level. .in -4 .ne 2 .B "*extensions* (list of symbols) .in +4 Compiled-in extensions. .in -4 .ne 2 .B "*library-path* (string) .in +4 A verbatim copy of the .I S9FES_LIBRARY_PATH environment variable (see below). .in -4 .ne 2 .B "*loading* (boolean) .in +4 Set to .B #t when \fBload\fPing a file, else \fB#f\fP. .in -4 .SH "MACROS A macro is a procedure that is applied to its unevaluated arguments. The macro application is replaced with the value returned by the procedure. This happens before the expression containing the macro application is evaluated, so a macro .I rewrites its own application: .sp .ne 2 .nf (define-syntax (when p . c) `(if ,p (begin ,@c))) (macro-expand '(when (= 1 1) (display "true") (newline) #t)) ==> (if (= 1 1) (begin (display "true") (newline) #t)) (when (= 1 1) 1 2 3) ==> 3 .fi .sp The .B define-syntax form introduces a new macro: .sp .ne 3 .B "(define-syntax name procedure) ==> unspecific .br .B "(define-syntax (name args ...) body) ==> unspecific .sp Both of these forms introduce the keyword .I name and bind it to a procedure. The first form requires the second argument to be a procedure. Like in .B define forms the second variant implies a procedure definition. .sp Macros may contain applications of macros that were defined earlier. Macros may not recurse directly, but they may implement recursion internally using .B letrec or by rewriting their own applications. The following macro, for example, does .I not work, because .I d is undefined in the body of .IR d : .sp .B "(define-syntax (d x) (and (pair? x) (d (cdr x)))) ; wrong" .sp The following version .I does work, though: .sp .B "(define-syntax (d x) (and (pair? x) `(d ,(cdr x)))) ; OK" .sp The body of .B define-syntax may be a .B syntax-rules transformer, as described in R4RS, if the .B syntax-rules extension has been loaded. .SH "TECHNICAL DETAILS S9fES is a tree-walking interpreter using deep binding and hashed environments. It employs an extremely reliable[1] constant-space mark and sweep garbage collector with in-situ string and vector pool compaction. Memory pools grow on demand. The interpreter uses arbitrary-precision integer arithmetics and (optional) decimal-based real number arithmetics. .SH "INTERPRETER START-UP When the .B s9 interpreter is started, the following steps will be performed in this order: .sp Load library. .in +4 The interpreter searches its library path (either built-in or specified in the .I S9FES_LIBRARY_PATH environment variable) for a heap image file or the library source code. The heap image file is the name of the interpreter with a .I .image suffix appended. An alternative name can be specified with the .B -i option (see .BR OPTIONS ). The default library source code is named .IR s9.scm . The first directory containing either a heap image or the library source code is used. When the directory contains both an image and the library sources, the image is loaded. .in -4 .sp Initialize extensions. .in +4 Any extensions compiled into the interpreter are initialized by calling the nullary procedure .B ext:ext (where .B ext is the name of the extension). The procedures are optional. The first `extension' being initialized is .B S9 itself, so when a procedure named .B s9:s9 exists, it will be called at this point. .in -4 .sp Evaluate command line options. .in +4 When a .I "-l file option is found, the program contained in the given file will be .BR load ed. When a .I "-f file args option is found, the program contained in the file will be run and then S9 will exit. .I Args will be passed to the program. .in -4 .sp Load rc file. .in +4 If an `rc file' (\fI$HOME/.s9fes/rc\fP) exists, it will be loaded at this point as if its name was passed to the .B load procedure. (Unless the .I -n option was specified.) .in -4 .sp .ne 2 Enter REPL. .in +4 Interactive mode is only entered, when no .I -f option was specified. .in -4 .SH "ALLOCATION STRATEGY The S9fES memory pool grows exponentially until the memory limit its reached. When the limit is reached, the current computation is aborted. A memory limit can be specified using the .B -m command line option. The limit is specified in units of 1024 nodes (or in units of 1024*1024 nodes by appending an .B m suffix). .br Note that computations may abort .I before the limit is reached due to the way the pool grows. Use the .B -g command line option to experiment with pool sizes. .br Specifying a limit of zero disables the memory limit completely and the interpreter will allocate as much memory as it can get. This option should be used with care. .SH "LIMITATIONS These parts of R4RS are not implemented: .sp I/O: .B char-ready? (this is in the .B sys-unix extension). .br Transcripts: .BR transcript-off , .BR transcript-on . .br Rational and complex numbers and related procedures. .SH "BUGS You may not quasiquote .B quasiquote unless in .BR unquote (e.g.: .B ``x does not work, but .B `,`x does). .br .B Syntax-rules is not fully hygienic. .br Multiple .BR call/cc 's in the arguments of the same .B lambda (or derived binding syntax, such as .BR let ) will break the evaluator. .SH "FILES .ne 2 .B $HOME/.s9fes/rc .in +4 If present, this file is .BR load ed when the interpreter starts in interactive mode. .in -4 .ne 2 .B @LIBDIR@ .in +4 The S9fES procedure library (source code). .in -4 .ne 2 .B @LIBDIR@/contrib .in +4 Contributions to the procedure library (source code). .in -4 .ne 2 .B @LIBDIR@/s9.image .in +4 The interpreter heap image. .in -4 .ne 2 .B *.scm .in +4 Scheme source code. .in -4 .SH "ENVIRONMENT .B S9FES_LIBRARY_PATH .in +4 A colon-separated list of directories which will be searched for the s9 library when the interpreter is launched. The same directories will be searched by the .B locate-file procedure. .br Default: .I \&.:~/.s9fes:@LIBDIR@ .in -4 .SH "SIGNALS These work only if POSIX signal handling was enabled at compile time. .sp .ne 3 .B "SIGINT .in +4 Abort input or terminate program execution. .in -4 .ne 3 .B "SIGQUIT .in +4 Terminate the interpreter process (emergency exit). .in -4 .B "SIGTERM .in +4 Silently terminate the interpreter process. .in -4 .SH "FOOTNOTES .B [1] See .I comp.lang.scheme Usenet message .in +4 .I " .br (Thu, 27 Aug 2009 13:27:42 -0400) and its follow-ups. .in -4 .SH "REFERENCES .ne 3 The Revised^4 Report on the Algorithmic Language Scheme. .in +4 .B "http://www-swiss.ai.mit.edu/~jaffer/r4rs_toc.html .in -4 .sp .ne 3 Scheme 9 from Empty Space -- A Guide to Implementing Scheme in C. .in +4 .B "Available at Lulu.com, see http://www.t3x.org .in -4 .SH AUTHOR Nils M Holm s9/s9-real.c000644 001751 001751 00000041001 12050150642 012430 0ustar00nmhnmh000000 000000 /* DO NOT EDIT THIS FILE! EDIT "edoc/s9-real.c.edoc" INSTEAD. */ /* * Scheme 9 from Empty Space, big real number arithmetics * By Nils M Holm, 2008-2010 * Placed in the Public Domain */ /* * Functions and macros with a "_real_" prefix expect data * objects of the primitive "real" type. Passing bignums to * them will result in mayhem. * * Functions with a "real_" prefix will delegate integer * operations to the corresponding bignum functions and * convert mixed arguments to real. */ char *ntoa(char *b, cell n, int w); cell bignum_shift_right(cell a); cell flat_copy(cell n, cell *lastp); int bignum_equal_p(cell a, cell b); int bignum_less_p(cell a, cell b); cell bignum_multiply(cell a, cell b); cell bignum_divide(cell x, cell a, cell b); cell bignum_negate(cell a); #define exponent_char_p(c) \ (c == 'd' || c == 'D' || \ c == 'e' || c == 'E' || \ c == 'f' || c == 'F' || \ c == 'l' || c == 'L' || \ c == 's' || c == 'S') int string_numeric_p(char *s) { int i; int got_digits = 0, got_expn = 0, got_point = 0, got_sign = 0; i = 0; if (s[0] == '+' || s[0] == '-') { i = 1; got_sign = 1; } if (!s[i]) return 0; while (s[i]) { if (exponent_char_p(s[i]) && got_digits && !got_expn) { if (isdigit((int) s[i+1]) || s[i+1] == '#') { got_expn = 1; } else if ((s[i+1] == '+' || s[i+1] == '-') && (isdigit((int) s[i+2]) || s[i+2] == '#') ) { got_expn = 1; i++; } else { return 0; } } else if (s[i] == '.' && !got_point) { got_point = 1; } else if (s[i] == '#' && (got_digits || got_point || got_sign) ) { got_digits = 1; } else if (isdigit((int) s[i])) { got_digits = 1; } else { return 0; } i++; } return 1; } char* replace_hashes(char *s) { char *new; new = copy_string(s); s = new; while (*s) { if (*s == '#') *s = '5'; s++; } return new; } cell make_real(int flags, cell exp, cell mant); cell real_normalize(cell x, char *who); cell string_to_bignum(char *numstr, int must_be_exact) { cell n, v; int k, j, sign, exact; char *s, *buf; buf = replace_hashes(numstr); exact = strchr(numstr, '#') == NULL; s = buf; sign = 1; if (s[0] == '-') { s++; sign = -1; } else if (s[0] == '+') { s++; } k = (int) strlen(s); n = NIL; while (k) { j = k <= DIGITS_PER_WORD? k: DIGITS_PER_WORD; v = atol(&s[k-j]); s[k-j] = 0; k -= j; if (k == 0) v *= sign; n = new_atom(v, n); } free(buf); if (exact || must_be_exact) return new_atom(T_INTEGER, n); car(n) = labs(car(n)); n = make_real((sign<0? REAL_NEGATIVE: 0), 0, n); return real_normalize(n, NULL); } cell make_integer(cell i); cell bignum_shift_left(cell a, int fill); cell bignum_add(cell a, cell b); cell string_to_real(char *s) { cell mantissa, n; cell exponent; int found_dp; int neg = 0; int i, j, v; mantissa = make_integer(0); save(mantissa); exponent = 0; i = 0; if (s[i] == '+') { i++; } else if (s[i] == '-') { neg = 1; i++; } found_dp = 0; while (isdigit((int) s[i]) || s[i] == '#' || s[i] == '.') { if (s[i] == '.') { i++; found_dp = 1; continue; } if (found_dp) exponent--; mantissa = bignum_shift_left(mantissa, 0); car(Stack) = mantissa; if (s[i] == '#') v = 5; else v = s[i]-'0'; mantissa = bignum_add(mantissa, make_integer(v)); car(Stack) = mantissa; i++; } j = 0; for (n = cdr(mantissa); n != NIL; n = cdr(n)) j++; if (exponent_char_p(s[i])) { i++; n = string_to_bignum(&s[i], 1); if (cddr(n) != NIL) { unsave(1); return error( "exponent too big in real number literal", make_string(s, strlen(s))); } exponent += integer_value("", n); } unsave(1); n = make_real((neg? REAL_NEGATIVE: 0), exponent, cdr(mantissa)); return real_normalize(n, NULL); } cell string_to_number(char *s) { int i; for (i=0; s[i]; i++) { if (s[i] == '.' || exponent_char_p(s[i])) return string_to_real(s); } return string_to_bignum(s, 0); } cell bignum_read(char *pre, int radix); cell bignum_abs(cell a); cell real_to_bignum(cell x); cell read_real_number(int inexact) { cell n, m; int flags; char buf[50]; n = read_form(0); if (integer_p(n)) { if (!inexact) return n; flags = _bignum_negative_p(n)? REAL_NEGATIVE: 0; m = bignum_abs(n); n = make_real(flags, 0, cdr(m)); return real_normalize(n, "numeric literal"); } else if (real_p(n)) { if (inexact) return n; m = real_to_bignum(n); if (m == NIL) return error("#e: no exact representation for", n); return m; } sprintf(buf, "number expected after #%c, got", inexact? 'i': 'e'); return error(buf, n); } void print_expanded_real(cell m, cell e, int n_digits, int neg) { char buf[DIGITS_PER_WORD+3]; int k, first; int dp_offset, old_offset; dp_offset = e+n_digits; if (neg) pr("-"); if (dp_offset <= 0) pr("0"); if (dp_offset < 0) pr("."); while (dp_offset < 0) { pr("0"); dp_offset++; } dp_offset = e+n_digits; first = 1; while (m != NIL) { ntoa(buf, labs(car(m)), first? 0: DIGITS_PER_WORD); k = strlen(buf); old_offset = dp_offset; dp_offset -= k; if (dp_offset < 0 && old_offset >= 0) { memmove(&buf[k+dp_offset+1], &buf[k+dp_offset], -dp_offset+1); buf[k+dp_offset] = '.'; } pr(buf); m = cdr(m); first = 0; } if (dp_offset >= 0) { while (dp_offset > 0) { pr("0"); dp_offset--; } pr(".0"); } } cell count_digits(cell m) { int k = 0; cell x; x = car(m); k = 0; while (x != 0) { x /= 10; k++; } k = k==0? 1: k; m = cdr(m); while (m != NIL) { k += DIGITS_PER_WORD; m = cdr(m); } return k; } cell round_last(cell m, cell e, int n_digits, int flags) { cell one; int r; m = bignum_shift_right(new_atom(T_INTEGER, m)); r = integer_value("print", cdr(m)); m = car(m); if (r >= 5) { save(m); one = make_integer(1); m = bignum_add(m, one); unsave(1); } m = cdr(m); n_digits--; e++; m = make_real(flags, e, m); return real_normalize(m, "print"); } /* Print real number. */ int print_real(cell n) { int n_digits; cell m, e; char buf[DIGITS_PER_WORD+2]; if (!real_p(n)) return 0; m = _real_mantissa(n); n_digits = count_digits(m); e = _real_exponent(n); if (n_digits == MANTISSA_SIZE && e < 0) { print_real(round_last(m, e, n_digits, _real_flags(n))); return 1; } if (e+n_digits > -4 && e+n_digits <= 6) { print_expanded_real(m, e, n_digits, _real_negative_flag(n)); return 1; } if (_real_negative_flag(n)) pr("-"); ntoa(buf, car(m), 0); pr_raw(buf, 1); pr("."); pr(buf[1] || cdr(m) != NIL? &buf[1]: "0"); m = cdr(m); while (m != NIL) { pr(ntoa(buf, car(m), DIGITS_PER_WORD)); m = cdr(m); } pr("e"); if (e+n_digits-1 >= 0) pr("+"); pr(ntoa(buf, e+n_digits-1, 0)); return 1; } /* * Real Number Arithmetics */ cell integer_argument(char *who, cell x) { cell n; char msg[100]; if (real_p(x)) { n = real_to_bignum(x); if (n == NIL) { sprintf(msg, "%s: expected integer, got", who); error(msg, x); return NIL; } return n; } return x; } cell make_real(int flags, cell exp, cell mant) { cell n; n = new_atom(exp, mant); n = new_atom(flags, n); return new_atom(T_REAL, n); } /* * Remove trailing zeros and move the decimal * point to the END of the mantissa, e.g.: * real_normalize(1.234e0) --> 1234e-3 * * Limit the mantissa to MANTISSA_SEGMENTS * machine words. This may cause a loss of * precision. * * Also handle numeric overflow/underflow. */ cell real_normalize(cell x, char *who) { cell m, e, r; int dgs; char buf[50]; save(x); e = _real_exponent(x); m = new_atom(T_INTEGER, _real_mantissa(x)); save(m); dgs = count_digits(cdr(m)); while (dgs > MANTISSA_SIZE) { r = bignum_shift_right(m); m = car(r); car(Stack) = m; dgs--; e++; } while (!_bignum_zero_p(m)) { r = bignum_shift_right(m); if (!_bignum_zero_p(cdr(r))) break; m = car(r); car(Stack) = m; e++; } if (_bignum_zero_p(m)) e = 0; r = new_atom(e, NIL); unsave(2); if (count_digits(r) > DIGITS_PER_WORD) { sprintf(buf, "%s: real number overflow", who? who: "internal"); error(buf, NOEXPR); } return make_real(_real_flags(x), e, cdr(m)); } cell bignum_to_real(cell a) { int e, flags, d; cell m, n; m = flat_copy(a, NULL); cadr(m) = labs(cadr(m)); e = 0; if (length(cdr(m)) > MANTISSA_SEGMENTS) { d = count_digits(cdr(m)); while (d > MANTISSA_SIZE) { m = car(bignum_shift_right(m)); e++; d--; } } flags = _bignum_negative_p(a)? REAL_NEGATIVE: 0; n = make_real(flags, e, cdr(m)); return real_normalize(n, NULL); } cell real_negate(cell a) { if (integer_p(a)) return bignum_negate(a); return _real_negate(a); } cell real_negative_p(cell a) { if (integer_p(a)) return _bignum_negative_p(a); return _real_negative_p(a); } cell real_positive_p(cell a) { if (integer_p(a)) return _bignum_positive_p(a); return _real_positive_p(a); } cell real_zero_p(cell a) { if (integer_p(a)) return _bignum_zero_p(a); return _real_zero_p(a); } cell real_abs(cell a) { if (integer_p(a)) return bignum_abs(a); if (_real_negative_p(a)) return _real_negate(a); return a; } int real_equal_p(cell a, cell b) { cell ma, mb; if (integer_p(a) && integer_p(b)) return bignum_equal_p(a, b); if (integer_p(a)) a = bignum_to_real(a); if (integer_p(b)) { save(a); b = bignum_to_real(b); unsave(1); } if (_real_exponent(a) != _real_exponent(b)) return 0; if (_real_zero_p(a) && _real_zero_p(b)) return 1; if (_real_negative_p(a) != _real_negative_p(b)) return 0; ma = _real_mantissa(a); mb = _real_mantissa(b); while (ma != NIL && mb != NIL) { if (car(ma) != car(mb)) return 0; ma = cdr(ma); mb = cdr(mb); } if (ma != mb) return 0; return 1; } /* * Scale the number R so that it gets exponent DESIRED_E * without changing its value. When there is not enough * room for scaling the mantissa of R, return NIL. * E.g.: scale_mantissa(1.0e0, -2, 0) --> 100.0e-2 * * Allow the mantissa to grow to MAX_SIZE segments. */ cell scale_mantissa(cell r, cell desired_e, int max_size) { int dgs; cell n, e; dgs = count_digits(_real_mantissa(r)); if (max_size && (max_size - dgs < _real_exponent(r) - desired_e)) return NIL; n = new_atom(T_INTEGER, flat_copy(_real_mantissa(r), NULL)); save(n); e = _real_exponent(r); while (e > desired_e) { n = bignum_shift_left(n, 0); car(Stack) = n; e--; } unsave(1); return make_real(_real_flags(r), e, cdr(n)); } void autoscale(cell *pa, cell *pb) { if (_real_exponent(*pa) < _real_exponent(*pb)) { *pb = scale_mantissa(*pb, _real_exponent(*pa), MANTISSA_SIZE*2); return; } if (_real_exponent(*pa) > _real_exponent(*pb)) { *pa = scale_mantissa(*pa, _real_exponent(*pb), MANTISSA_SIZE*2); } } int real_less_p(cell a, cell b) { cell ma, mb; int ka, kb, neg; int dpa, dpb; if (integer_p(a) && integer_p(b)) return bignum_less_p(a, b); if (integer_p(a)) a = bignum_to_real(a); if (integer_p(b)) { save(a); b = bignum_to_real(b); unsave(1); } if (_real_negative_p(a) && !_real_negative_p(b)) return 1; if (_real_negative_p(b) && !_real_negative_p(a)) return 0; if (_real_zero_p(a) && _real_positive_p(b)) return 1; if (_real_zero_p(b) && _real_positive_p(a)) return 0; neg = _real_negative_p(a); dpa = count_digits(_real_mantissa(a)) + _real_exponent(a); dpb = count_digits(_real_mantissa(b)) + _real_exponent(b); if (dpa < dpb) return neg? 0: 1; if (dpa > dpb) return neg? 1: 0; Tmp = b; save(a); save(b); Tmp = NIL; autoscale(&a, &b); unsave(2); if (a == NIL) return neg? 1: 0; if (b == NIL) return neg? 0: 1; ma = _real_mantissa(a); mb = _real_mantissa(b); ka = length(ma); kb = length(mb); if (ka < kb) return 1; if (ka > kb) return 0; while (ma != NIL) { if (car(ma) < car(mb)) return neg? 0: 1; if (car(ma) > car(mb)) return neg? 1: 0; ma = cdr(ma); mb = cdr(mb); } return 0; } cell real_add(cell a, cell b) { cell r, m, e, aa, ab; int flags, nega, negb; if (integer_p(a) && integer_p(b)) return bignum_add(a, b); if (integer_p(a)) a = bignum_to_real(a); save(a); if (integer_p(b)) b = bignum_to_real(b); save(b); if (_real_zero_p(a)) { unsave(2); return b; } if (_real_zero_p(b)) { unsave(2); return a; } autoscale(&a, &b); if (a == NIL || b == NIL) { ab = real_abs(car(Stack)); save(ab); aa = real_abs(caddr(Stack)); unsave(1); b = unsave(1); a = unsave(1); return real_less_p(aa, ab)? b: a; } cadr(Stack) = a; car(Stack) = b; e = _real_exponent(a); nega = _real_negative_p(a); negb = _real_negative_p(b); a = new_atom(T_INTEGER, _real_mantissa(a)); if (nega) a = bignum_negate(a); cadr(Stack) = a; b = new_atom(T_INTEGER, _real_mantissa(b)); if (negb) b = bignum_negate(b); car(Stack) = b; m = bignum_add(a, b); unsave(2); flags = _bignum_negative_p(m)? REAL_NEGATIVE: 0; r = make_real(flags, e, cdr(bignum_abs(m))); return real_normalize(r, "+"); } cell real_subtract(cell a, cell b) { cell r; if (integer_p(b)) b = bignum_negate(b); else b = _real_negate(b); save(b); r = real_add(a, b); unsave(1); return r; } cell real_multiply(cell a, cell b) { cell r, m, e, ma, mb, ea, eb, neg; if (integer_p(a) && integer_p(b)) return bignum_multiply(a, b); if (integer_p(a)) a = bignum_to_real(a); save(a); if (integer_p(b)) b = bignum_to_real(b); save(b); neg = _real_negative_flag(a) != _real_negative_flag(b); ea = _real_exponent(a); eb = _real_exponent(b); ma = new_atom(T_INTEGER, _real_mantissa(a)); cadr(Stack) = ma; mb = new_atom(T_INTEGER, _real_mantissa(b)); car(Stack) = mb; e = ea + eb; m = bignum_multiply(ma, mb); unsave(2); r = make_real(neg? REAL_NEGATIVE: 0, e, cdr(m)); return real_normalize(r, "*"); } cell real_divide(cell x, cell a, cell b) { cell r, m, e, ma, mb, ea, eb, neg; int nd, dd; if (integer_p(a)) a = bignum_to_real(a); if (_real_zero_p(a)) { return make_real(0, 0, cdr(make_integer(0))); } save(a); if (integer_p(b)) b = bignum_to_real(b); save(b); neg = _real_negative_flag(a) != _real_negative_flag(b); ea = _real_exponent(a); eb = _real_exponent(b); ma = new_atom(T_INTEGER, _real_mantissa(a)); cadr(Stack) = ma; mb = new_atom(T_INTEGER, _real_mantissa(b)); car(Stack) = mb; if (_bignum_zero_p(mb)) { unsave(2); return NAN; } nd = count_digits(cdr(ma)); dd = MANTISSA_SIZE + count_digits(cdr(mb)); while (nd < dd) { ma = bignum_shift_left(ma, 0); cadr(Stack) = ma; nd++; ea--; } e = ea - eb; m = bignum_divide(NOEXPR, ma, mb); unsave(2); r = make_real(neg? REAL_NEGATIVE: 0, e, cdar(m)); return real_normalize(r, "/"); } cell real_to_bignum(cell r) { cell n; int neg; if (_real_exponent(r) >= 0) { neg = _real_negative_p(r); n = scale_mantissa(r, 0, 0); if (n == NIL) return NIL; n = new_atom(T_INTEGER, _real_mantissa(n)); if (neg) n = bignum_negate(n); return n; } return NIL; } cell real_integer_p(cell x) { if (integer_p(x)) return 1; if (real_p(x) && real_to_bignum(x) != NIL) return 1; return 0; } cell pp_divide(cell x) { cell a, expr; expr = x; x = cdr(x); if (cdr(x) == NIL) { a = make_integer(1); save(a); a = real_divide(expr, a, car(x)); unsave(1); return a; } a = car(x); x = cdr(x); save(a); while (x != NIL) { if (!number_p(car(x))) { unsave(1); return error("/: expected number, got", car(x)); } a = real_divide(expr, a, car(x)); car(Stack) = a; x = cdr(x); } unsave(1); return a; } cell pp_exact_to_inexact(cell x) { cell n; int flags; x = cadr(x); if (integer_p(x)) { flags = _bignum_negative_p(x)? REAL_NEGATIVE: 0; n = make_real(flags, 0, cdr(bignum_abs(x))); return real_normalize(n, "exact->inexact"); } return x; } cell pp_exact_p(cell x) { return integer_p(cadr(x))? TRUE: FALSE; } cell pp_exponent(cell x) { if (integer_p(cadr(x))) return make_integer(0); return make_integer(_real_exponent(cadr(x))); } cell pp_floor(cell x) { cell n, m, e; x = cadr(x); e = _real_exponent(x); if (e >= 0) return x; m = new_atom(T_INTEGER, _real_mantissa(x)); save(m); while (e < 0) { m = bignum_shift_right(m); m = car(m); car(Stack) = m; e++; } if (_real_negative_p(x)) { /* sign not in mantissa! */ m = bignum_add(m, make_integer(1)); } unsave(1); n = make_real(_real_flags(x), e, cdr(m)); return real_normalize(n, "floor"); } cell pp_inexact_p(cell x) { return real_p(cadr(x))? TRUE: FALSE; } cell pp_inexact_to_exact(cell x) { cell n; x = cadr(x); if (integer_p(x)) return x; n = real_to_bignum(x); if (n != NIL) return n; return error("inexact->exact: no exact representation for", x); } cell pp_mantissa(cell x) { cell m; if (integer_p(cadr(x))) return cadr(x); m = new_atom(T_INTEGER, _real_mantissa(cadr(x))); if (_real_negative_p(cadr(x))) m = bignum_negate(m); return m; } cell pp_real_p(cell x) { return number_p(cadr(x))? TRUE: FALSE; } s9/s9.h000644 001751 001751 00000031146 12244426005 011531 0ustar00nmhnmh000000 000000 /* DO NOT EDIT THIS FILE! EDIT "edoc/s9.h.edoc" INSTEAD. */ /* * Scheme 9 from Empty Space * By Nils M Holm, 2007-2012 * Placed in the Public Domain */ /* * Ugly prelude to figure out if * we are compiling on a Un*x system. */ #ifdef __NetBSD__ #ifndef unix #define unix #endif #endif #ifdef __unix #ifndef unix #define unix #endif #endif #ifdef __linux #ifndef unix #define unix #endif #endif #ifndef unix #ifndef plan9 #error "Either 'unix' or 'plan9' must be #defined." #endif #endif #ifdef unix #ifndef _BSD_SOURCE #define _BSD_SOURCE #endif #ifndef __FreeBSD__ #ifndef __NetBSD__ #ifndef _POSIX_SOURCE #define _POSIX_SOURCE #define _POSIX_C_SOURCE 200112L #endif #ifndef _XOPEN_SOURCE #define _XOPEN_SOURCE 500 #endif #endif #endif #endif #ifdef plan9 #include #include #include #include #define NO_SIGNALS #define signal(sig, fn) #define exit(x) exits((x)? "error": NULL) #define ptrdiff_t int #endif #ifdef unix #include #include #include #include #include #ifdef NO_SIGNALS #define signal(sig, fn) #else #include #ifndef SIGQUIT /* MinGW does not define SIGQUIT */ #define SIGQUIT SIGINT #endif #endif #endif /* * Tell later MSC compilers to let us use the standard CLIB API. * Blake McBride < b l a k e at m c b r i d e . n a m e > */ #ifdef _MSC_VER #if _MSC_VER > 1200 #ifndef _CRT_SECURE_NO_DEPRECATE #define _CRT_SECURE_NO_DEPRECATE #endif #endif #ifndef _POSIX_ #define _POSIX_ #endif #endif #ifndef DEFAULT_LIBRARY_PATH #define DEFAULT_LIBRARY_PATH \ "." \ ":lib" \ ":ext" \ ":contrib" \ ":~/.s9fes" \ ":/usr/local/share/s9fes" #endif #ifndef INITIAL_SEGMENT_SIZE #define INITIAL_SEGMENT_SIZE 32768 #endif #define TOKEN_LENGTH 1024 #define MAX_PORTS 32 #define MAX_IO_DEPTH 65536 /* Reduce on 16-bit systems! */ #define HASH_THRESHOLD 5 #define MAX_CALL_TRACE 100 /* Default memory limit in K-nodes, 0 = none */ #define DEFAULT_LIMIT_KN 12392 /* A "cell" must be large enough to hold a pointer */ #define cell ptrdiff_t /* 64-bit emulation on 32-bit system; DO NOT USE! */ #ifdef EMULATE_64 #undef BITS_PER_WORD_32 #define BITS_PER_WORD_64 #undef cell #define cell long long #define labs(x) llabs(x) #define atol(x) atoll(x) #endif /* Pick one ... */ /* #define BITS_PER_WORD_64 */ /* #define BITS_PER_WORD_32 */ /* #define BITS_PER_WORD_16 */ /* ... or assume a reasonable default */ #ifndef BITS_PER_WORD_16 #ifndef BITS_PER_WORD_32 #ifndef BITS_PER_WORD_64 #define BITS_PER_WORD_32 #endif #endif #endif /* * N-bit arithmetics require sizeof(cell) >= N/8. * When MANTISSA_SIZE (below) gets more than 60 places, you * will have to supply a better value for PI in "s9-real.scm". */ #ifdef BITS_PER_WORD_64 #define DIGITS_PER_WORD 18 #ifdef EMULATE_64 #define INT_SEG_LIMIT 1000000000000000000LL #else #define INT_SEG_LIMIT 1000000000000000000L #endif #define MANTISSA_SEGMENTS 1 #else #ifdef BITS_PER_WORD_32 #define DIGITS_PER_WORD 9 #define INT_SEG_LIMIT 1000000000L #define MANTISSA_SEGMENTS 2 #else #ifdef BITS_PER_WORD_16 #define DIGITS_PER_WORD 4 #define INT_SEG_LIMIT 10000 #define MANTISSA_SEGMENTS 3 #else #error "BITS_PER_WORD_* undefined (this should not happen)" #endif #endif #endif /* Mantissa sizes differ among systems */ #define MANTISSA_SIZE (MANTISSA_SEGMENTS * DIGITS_PER_WORD) /* * Node tags */ #define ATOM_TAG 0x01 /* Atom, Car = type, CDR = next */ #define MARK_TAG 0x02 /* Mark */ #define STATE_TAG 0x04 /* State */ #define VECTOR_TAG 0x08 /* Vector, Car = type, CDR = content */ #define PORT_TAG 0x10 /* Atom is an I/O port (with ATOM_TAG) */ #define USED_TAG 0x20 /* Port: used flag */ #define LOCK_TAG 0x40 /* Port: locked (do not close) */ #define CONST_TAG 0x80 /* Node is immutable */ /* * Evaluator states */ enum EVAL_STATES { EV_ATOM, /* Evaluating atom */ EV_ARGS, /* Evaluating argument list */ EV_BETA, /* Evaluating procedure body */ EV_IF_PRED, /* Evaluating predicate of IF */ EV_SET_VAL, /* Evaluating value of SET! and DEFINE */ EV_MACRO, /* Evaluating value of DEFINE-SYNTAX */ EV_BEGIN, /* Evaluating expressions of BEGIN */ EV_AND, /* Evaluating arguments of AND */ EV_OR, /* Evaluating arguments of OR */ EV_COND /* Evaluating clauses of COND */ }; /* * Binding structure */ #define make_binding(v, a) (cons((v), (a))) #define binding_box(x) (x) #define binding_value(x) (cdr(x)) #define box_value(x) (cdr(x)) /* * Special objects */ #define special_value_p(x) ((x) < 0) #define NIL (-1) #define TRUE (-2) #define FALSE (-3) #define END_OF_FILE (-4) #define UNDEFINED (-5) #define UNSPECIFIC (-6) #define NAN (-7) #define DOT (-8) #define RPAREN (-9) #define RBRACK (-10) #define NOEXPR (-11) /* * Types */ #define T_NONE (-20) #define T_BOOLEAN (-21) #define T_CHAR (-22) #define T_INPUT_PORT (-23) #define T_INTEGER (-24) #define T_OUTPUT_PORT (-25) #define T_PAIR (-26) #define T_PAIR_OR_NIL (-27) #define T_PRIMITIVE (-28) #define T_PROCEDURE (-29) #define T_REAL (-30) #define T_STRING (-31) #define T_SYMBOL (-32) #define T_SYNTAX (-33) #define T_VECTOR (-34) #define T_CONTINUATION (-35) /* * Short cuts for primitive procedure definitions */ #define BOL T_BOOLEAN #define CHR T_CHAR #define INP T_INPUT_PORT #define INT T_INTEGER #define LST T_PAIR_OR_NIL #define OUP T_OUTPUT_PORT #define PAI T_PAIR #define PRC T_PROCEDURE #define REA T_REAL #define STR T_STRING #define SYM T_SYMBOL #define VEC T_VECTOR #define ___ T_NONE struct Primitive_procedure { char *name; cell (*handler)(cell expr); int min_args; int max_args; /* -1 = variadic */ int arg_types[3]; }; #define PRIM struct Primitive_procedure /* * Globals */ #ifndef EXTERN #define EXTERN extern #endif EXTERN int Cons_segment_size, Vec_segment_size; EXTERN int Cons_pool_size, Vec_pool_size; EXTERN cell *Car, *Cdr; EXTERN char *Tag; EXTERN cell *Vectors; EXTERN cell Free_list; EXTERN cell Free_vecs; EXTERN cell Stack, Stack_bottom; EXTERN cell State_stack; EXTERN cell Tmp_car, Tmp_cdr, Tmp; EXTERN cell Symbols; EXTERN cell Program; EXTERN cell Environment; EXTERN cell Acc; EXTERN PRIM *Apply_magic, *Call_magic; EXTERN cell New; EXTERN int Level; EXTERN int Load_level; EXTERN int Displaying; EXTERN cell Called_procedures[MAX_CALL_TRACE]; EXTERN int Proc_ptr, Proc_max; EXTERN cell File_list; EXTERN int Line_no; EXTERN int Printer_count, Printer_limit; EXTERN cell Trace_list; EXTERN FILE *Ports[MAX_PORTS]; EXTERN char Port_flags[MAX_PORTS]; EXTERN int Input_port, Output_port, Error_port; EXTERN char **Command_line; EXTERN long Memory_limit_kn; EXTERN int Quiet_mode; EXTERN volatile int Error_flag; /* Short cuts for accessing predefined symbols */ EXTERN cell S_arrow, S_else, S_extensions, S_latest, S_library_path, S_loading, S_quasiquote, S_quote, S_unquote, S_unquote_splicing; EXTERN cell S_and, S_begin, S_cond, S_define, S_define_syntax, S_if, S_lambda, S_or, S_set_b; /* * I/O */ #define nl() pr("\n") #define reject(c) ungetc(c, Ports[Input_port]) #define read_c() getc(Ports[Input_port]) #define read_c_ci() tolower(read_c()) /* * Access to fields of atoms */ #define string(n) ((char *) &Vectors[Cdr[n]]) #define string_len(n) (Vectors[Cdr[n] - 1]) #define symbol_name(n) (string(n)) #define symbol_len(n) (string_len(n)) #define vector(n) (&Vectors[Cdr[n]]) #define vector_link(n) (Vectors[Cdr[n] - 3]) #define vector_index(n) (Vectors[Cdr[n] - 2]) #define vector_size(k) (((k) + sizeof(cell)-1) / sizeof(cell) + 3) #define vector_len(n) (vector_size(string_len(n)) - 3) #define port_no(n) (cadr(n)) #define char_value(n) (cadr(n)) /* * Internal vector representation */ #define RAW_VECTOR_LINK 0 #define RAW_VECTOR_INDEX 1 #define RAW_VECTOR_SIZE 2 #define RAW_VECTOR_DATA 3 /* * Flags and structure of real numbers */ #define _real_flags(x) (cadr(x)) #define _real_exponent(x) (caddr(x)) #define _real_mantissa(x) (cdddr(x)) #define REAL_NEGATIVE 0x01 #define _real_negative_flag(x) (_real_flags(x) & REAL_NEGATIVE) /* * Nested lists */ #define car(x) (Car[x]) #define cdr(x) (Cdr[x]) #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 caaddr(x) (Car[Car[Cdr[Cdr[x]]]]) #define caddar(x) (Car[Cdr[Cdr[Car[x]]]]) #define cadadr(x) (Car[Cdr[Car[Cdr[x]]]]) #define cadddr(x) (Car[Cdr[Cdr[Cdr[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]]]]) /* * Type predicates */ #define eof_p(n) ((n) == END_OF_FILE) #define undefined_p(n) ((n) == UNDEFINED) #define unspecific_p(n) ((n) == UNSPECIFIC) #define boolean_p(n) ((n) == TRUE || (n) == FALSE) #define constant_p(n) (!special_value_p(n) && (Tag[n] & CONST_TAG)) #define integer_p(n) \ (!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_INTEGER) #define number_p(n) \ (!special_value_p(n) && (Tag[n] & ATOM_TAG) && \ (Car[n] == T_REAL || Car[n] == T_INTEGER)) #define primitive_p(n) \ (!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_PRIMITIVE) #define procedure_p(n) \ (!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_PROCEDURE) #define continuation_p(n) \ (!special_value_p(n) && (Tag[n] & ATOM_TAG) && \ Car[n] == T_CONTINUATION) #define real_p(n) \ (!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_REAL) #define special_p(n) ((n) == S_quote || \ (n) == S_begin || \ (n) == S_if || \ (n) == S_cond || \ (n) == S_and || \ (n) == S_or || \ (n) == S_lambda || \ (n) == S_set_b || \ (n) == S_define || \ (n) == S_define_syntax) #define char_p(n) \ (!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_CHAR) #define syntax_p(n) \ (!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_SYNTAX) #define input_port_p(n) \ (!special_value_p(n) && (Tag[n] & ATOM_TAG) && (Tag[n] & PORT_TAG) \ && Car[n] == T_INPUT_PORT) #define output_port_p(n) \ (!special_value_p(n) && (Tag[n] & ATOM_TAG) && (Tag[n] & PORT_TAG) \ && Car[n] == T_OUTPUT_PORT) #define symbol_p(n) \ (!special_value_p(n) && (Tag[n] & VECTOR_TAG) && Car[n] == T_SYMBOL) #define vector_p(n) \ (!special_value_p(n) && (Tag[n] & VECTOR_TAG) && Car[n] == T_VECTOR) #define string_p(n) \ (!special_value_p(n) && (Tag[n] & VECTOR_TAG) && Car[n] == T_STRING) #define atom_p(n) \ (special_value_p(n) || (Tag[n] & ATOM_TAG) || (Tag[n] & VECTOR_TAG)) #define auto_quoting_p(n) atom_p(n) #define pair_p(x) (!atom_p(x)) /* * Rib structure */ #define rib_args(x) (car(x)) #define rib_append(x) (cadr(x)) #define rib_result(x) (caddr(x)) #define rib_source(x) (cdddr(x)) /* * Allocators */ #define cons(pa, pd) cons3((pa), (pd), 0) #define new_atom(pa, pd) cons3((pa), (pd), ATOM_TAG) #define save(n) (Stack = cons((n), Stack)) #define save_state(v) (State_stack = cons3((v), State_stack, ATOM_TAG)) /* * Bignum arithmitcs */ #define _bignum_negative_p(a) ((cadr(a)) < 0) #define _bignum_zero_p(a) ((cadr(a) == 0) && (cddr(a)) == NIL) #define _bignum_positive_p(a) \ (!_bignum_negative_p(a) && !_bignum_zero_p(a)) /* * Real-number arithmetics */ #define _real_zero_p(x) \ (car(_real_mantissa(x)) == 0 && cdr(_real_mantissa(x)) == NIL) #define _real_negative_p(x) \ (_real_negative_flag(x) && !_real_zero_p(x)) #define _real_positive_p(x) \ (!_real_negative_flag(x) && !_real_zero_p(x)) #define _real_negate(a) \ make_real(_real_flags(a) & REAL_NEGATIVE? \ _real_flags(a) & ~REAL_NEGATIVE: \ _real_flags(a) | REAL_NEGATIVE, \ _real_exponent(a), _real_mantissa(a)) /* * Prototypes */ void add_primitives(char *name, PRIM *p); cell symbol_ref(char *s); cell cons3(cell pcar, cell pcdr, int ptag); int new_port(void); char *copy_string(char *s); cell error(char *msg, cell expr); void fatal(char *msg); cell integer_value(char *src, cell x); int length(cell x); cell make_char(int c); cell make_integer(cell i); cell make_port(int portno, cell type); cell make_string(char *s, int k); cell unsave(int k); s9/util/000755 001751 001751 00000000000 12051121735 011773 5ustar00nmhnmh000000 000000 s9/s9.1.txt000644 001751 001751 00000044034 12245077506 012271 0ustar00nmhnmh000000 000000 S9(1) Scheme 9 from Empty Space S9(1) NAME s9 - Scheme Interpreter USAGE s9 [-h?] [-i name] [-gnqv] [-m size[m]] [-f prog [args]] [-l prog] [-t count] [-d image] [-- [args]] DESCRIPTION Scheme 9 from Empty Space is an interpreter for R4RS Scheme with some additional procedures for accessing typical Unix system calls and Unix and Curses library functions (if compiled-in). The s9 command starts the interpreter. OPTIONS -h or -? Display a brief summary of options. -i name Load alternative image file `name.image'. When no image file can be found, try to load `name.scm'. The file will be searched in the entire S9FES_LIBRARY_PATH (see below). When this option is used, it must be the first one of the s9 command. When `-' is specified as name, no heap image will be loaded, and the core library will be read from the source file `s9.scm'. -d file Dump heap image to file and exit. -f program [arguments] Run program and exit (implies -q). When there are any arguments, they are passed to the program, where they can be extracted using the command-line procedure. -g Print GC summaries (-gg = more verbose). -n Do not load $HOME/.s9fes/rc file, if any. -l program Load program before entering the REPL or processing -f (may be repeated). -m N[m] Set memory limit to N kilo (or mega) nodes (-m 0 means no limit; use with care!). -q Be quiet: skip banners and prompts, exit on errors. -t count Display count procedures at most in call traces. -v Display version and exit. -- [argument ...] Arguments following -- are not interpreted by S9fES, but passed to the command-line procedure instead (requires the unix extension). ONLINE HELP When the interpreter is running and the default heap image is loaded, just type (help) or ,h to invoke the online help system. When the online help system is not loaded, you will have to run the following command first: S9 Interpreter Page 1 S9(1) S9(1) Scheme 9 from Empty Space S9(1) (load-from-library "help.scm") META COMMANDS In order to facilitate the invocation of frequently-used top-level procedures, s9 provides the following "meta commands" (they work only when entered directly at the s9 prompt): ,a text = (apropos "text") ,h text = (help "text") ,l file = (load-from-library "file") ,q = (sys:exit) The arguments of ,a and ,h are optional. ADDITIONS S9fES supports nestable block comments of the form #| comment ... |#. Square brackets may be used in the places of parentheses: (cond [(foo) (bar)]). The same type of bracket must be used on both ends of a list. These S9fES procedures are not in R4RS: (argv integer) ==> string | #f Retrieve the value of the given command line argument. Return #f, if there are less than integer+1 arguments. Arguments start at 0. (bit-op integer1 integer2 integer3 ...) ==> integer | #f Implement a variety of bitwise operations. See the bit- op help page for details. (delete-file string) ==> unspecific Delete the file specified in the string argument. If the file does not exist or cannot be deleted, report an error. (dump-image string) ==> unspecific Write a heap image to the file given in the string argument. If the file already exists, report an error. (environ string) ==> string | #f Retrieve the value of the given environment variable. Return #f, if the variable is undefined. (error string) ==> undefined (error string object) ==> undefined Print an error message of the form error: string: object and terminate program execution. S9 Interpreter Page 2 S9(1) S9(1) Scheme 9 from Empty Space S9(1) (exponent real) ==> integer Extract the exponent part from a real number. (file-exists? string) ==> boolean Return #t if the file specified in the string argument exists and otherwise #f. (fold-left proc base list ...) ==> object Combine the elements of the lists using proc. Combine elements left-associatively. Base is the leftmost element. (fold-right proc base list ...) ==> object Combine the elements of the lists using proc. Combine elements right-associatively. Base is the rightmost element. (gensym) ==> symbol (gensym symbol) ==> symbol (gensym string) ==> symbol Return a fresh symbol. When a string or symbol argument is given, use it as prefix for the fresh symbol. (load-from-library string) ==> unspecific Attempt to load the file string from each directory of S9FES_LIBRARY_PATH. (locate-file string) ==> string | #f Search for the file string in each directory of S9FES_LIBRARY_PATH in sequence. When the file can be located, return its full path, else return #f. (macro-expand object) ==> object (macro-expand-1 object) ==> object If object is a list resembling a macro application, return the expanded form, else return the object. Macro-expand-1 expands macros only once while macro- expand expands them recursively. (mantissa real) ==> integer Extract the mantissa part from a real number. (print object ...) ==> unspecific Write multiple objects separated by spaces. (require-extension name ...) ==> unspecific Require the named extensions to be compiled-in. Signal an error if not all of the required extensions are present. (reverse! list) ==> list Reverse list destructively and return the reverse list. (set-input-port! input-port) ==> unspecific Destructively set the current input port. (set-output-port! output-port) ==> unspecific Destructively set the current output port. S9 Interpreter Page 3 S9(1) S9(1) Scheme 9 from Empty Space S9(1) (stats form) ==> form Evaluate the given form and return a list containing its normal form plus a summary of the resources used to compute that normal form: - reduction steps - conses allocated - total nodes allocated - garbage collections Each resource count will be returned as a group of integers representing ones, thousands, millions, etc. Note that form must be quoted or it will be evaluated before passing it to stats. (symbols) ==> list Return a list of all defined symbols. (system string) ==> number Run the given shell command and return its exit code. (trace symbol ...) ==> list | #t (trace #t) ==> list | #t Trace the procedure or syntax object bound to the given symbols. When #t is passed to trace, trace all procedures and syntax objects (expect lots of output!). When no arguments are passed to it, disable tracing. Trace returns the symbols that were being traced before its invocation. (vector-append vector ...) ==> vector Return a fresh vector containing the concatenation of the given vectors. (vector-copy vector) ==> vector (vector-copy vector integer) ==> vector (vector-copy vector integer1 integer2) ==> vector (vector-copy vector integer1 integer2 object) ==> vector Return a copy of the given vector. When integer1 is specified, skip the given number of elements. When integer2 is also specified, copy elements from integer1 up to, but not including, integer2. When integer2 exceeds the size of the original vector, add unspecific slots to the copy. When an object argument is given, fill extra slots with that argument. (void) ==> unspecific Return an unspecific value. Refer to the help pages for descriptions of the Scheme 9 extension procedures. SPECIAL VARIABLES These variables are predefined in the dynamic top-level scope of the interpreter. S9 Interpreter Page 4 S9(1) S9(1) Scheme 9 from Empty Space S9(1) ** (form) The normal form of the expression most recently evaluated at the top level. *extensions* (list of symbols) Compiled-in extensions. *library-path* (string) A verbatim copy of the S9FES_LIBRARY_PATH environment variable (see below). *loading* (boolean) Set to #t when loading a file, else #f. MACROS A macro is a procedure that is applied to its unevaluated arguments. The macro application is replaced with the value returned by the procedure. This happens before the expression containing the macro application is evaluated, so a macro rewrites its own application: (define-syntax (when p . c) `(if ,p (begin ,@c))) (macro-expand '(when (= 1 1) (display "true") (newline) #t)) ==> (if (= 1 1) (begin (display "true") (newline) #t)) (when (= 1 1) 1 2 3) ==> 3 The define-syntax form introduces a new macro: (define-syntax name procedure) ==> unspecific (define-syntax (name args ...) body) ==> unspecific Both of these forms introduce the keyword name and bind it to a procedure. The first form requires the second argument to be a procedure. Like in define forms the second variant implies a procedure definition. Macros may contain applications of macros that were defined earlier. Macros may not recurse directly, but they may implement recursion internally using letrec or by rewriting their own applications. The following macro, for example, does not work, because d is undefined in the body of d: (define-syntax (d x) (and (pair? x) (d (cdr x)))) ; wrong The following version does work, though: (define-syntax (d x) (and (pair? x) `(d ,(cdr x)))) ; OK The body of define-syntax may be a syntax-rules transformer, as described in R4RS, if the syntax-rules extension has been loaded. TECHNICAL DETAILS S9fES is a tree-walking interpreter using deep binding and hashed environments. It employs an extremely reliable[1] constant-space mark and sweep garbage collector with in-situ string and vector pool compaction. Memory pools grow on S9 Interpreter Page 5 S9(1) S9(1) Scheme 9 from Empty Space S9(1) demand. The interpreter uses arbitrary-precision integer arithmetics and (optional) decimal-based real number arithmetics. INTERPRETER START-UP When the s9 interpreter is started, the following steps will be performed in this order: Load library. The interpreter searches its library path (either built- in or specified in the S9FES_LIBRARY_PATH environment variable) for a heap image file or the library source code. The heap image file is the name of the interpreter with a .image suffix appended. An alternative name can be specified with the -i option (see OPTIONS). The default library source code is named s9.scm. The first directory containing either a heap image or the library source code is used. When the directory contains both an image and the library sources, the image is loaded. Initialize extensions. Any extensions compiled into the interpreter are initialized by calling the nullary procedure ext:ext (where ext is the name of the extension). The procedures are optional. The first `extension' being initialized is S9 itself, so when a procedure named s9:s9 exists, it will be called at this point. Evaluate command line options. When a -l file option is found, the program contained in the given file will be loaded. When a -f file args option is found, the program contained in the file will be run and then S9 will exit. Args will be passed to the program. Load rc file. If an `rc file' ($HOME/.s9fes/rc) exists, it will be loaded at this point as if its name was passed to the load procedure. (Unless the -n option was specified.) Enter REPL. Interactive mode is only entered, when no -f option was specified. ALLOCATION STRATEGY The S9fES memory pool grows exponentially until the memory limit its reached. When the limit is reached, the current computation is aborted. A memory limit can be specified using the -m command line option. The limit is specified in units of 1024 nodes (or in units of 1024*1024 nodes by appending an m suffix). Note that computations may abort before the limit is reached due to the way the pool grows. Use the -g command line option to experiment with pool sizes. Specifying a limit of zero disables the memory limit completely and the interpreter will allocate as much memory S9 Interpreter Page 6 S9(1) S9(1) Scheme 9 from Empty Space S9(1) as it can get. This option should be used with care. LIMITATIONS These parts of R4RS are not implemented: I/O: char-ready? (this is in the sys-unix extension). Transcripts: transcript-off, transcript-on. Rational and complex numbers and related procedures. BUGS You may not quasiquote quasiquote unless in unquote (e.g.: ``x does not work, but `,`x does). Syntax-rules is not fully hygienic. Multiple call/cc's in the arguments of the same lambda (or derived binding syntax, such as let) will break the evaluator. FILES $HOME/.s9fes/rc If present, this file is loaded when the interpreter starts in interactive mode. @LIBDIR@ The S9fES procedure library (source code). @LIBDIR@/contrib Contributions to the procedure library (source code). @LIBDIR@/s9.image The interpreter heap image. *.scm Scheme source code. ENVIRONMENT S9FES_LIBRARY_PATH A colon-separated list of directories which will be searched for the s9 library when the interpreter is launched. The same directories will be searched by the locate-file procedure. Default: .:~/.s9fes:@LIBDIR@ SIGNALS These work only if POSIX signal handling was enabled at compile time. SIGINT Abort input or terminate program execution. SIGQUIT Terminate the interpreter process (emergency exit). SIGTERM Silently terminate the interpreter process. FOOTNOTES [1] See comp.lang.scheme Usenet message (Thu, 27 Aug 2009 13:27:42 -0400) and its follow-ups. REFERENCES The Revised^4 Report on the Algorithmic Language Scheme. http://www-swiss.ai.mit.edu/~jaffer/r4rs_toc.html S9 Interpreter Page 7 S9(1) S9(1) Scheme 9 from Empty Space S9(1) Scheme 9 from Empty Space -- A Guide to Implementing Scheme in C. Available at Lulu.com, see http://www.t3x.org AUTHOR Nils M Holm S9 Interpreter Page 8 S9(1) s9/config.scm000644 001751 001751 00000001216 11424556515 013002 0ustar00nmhnmh000000 000000 ; Configuration file for the S9 default heap image. ; Choose your extras or add your own stuff. (load-from-library "help.scm") (load-from-library "pretty-print.scm") (load-from-library "draw-tree.scm") (load-from-library "hash-table.scm") (load-from-library "keyword-value.scm") (load-from-library "id.scm") (load-from-library "graph-tools.scm") (load-from-library "io-tools.scm") (load-from-library "list-tools.scm") (load-from-library "math-tools.scm") (load-from-library "set-tools.scm") (load-from-library "string-tools.scm") (load-from-library "syntax-extensions.scm") (load-from-library "vector-tools.scm") (load-from-library "unix-tools.scm") s9/prog/000755 001751 001751 00000000000 12054356470 011776 5ustar00nmhnmh000000 000000 s9/ABOUT000644 001751 001751 00000001771 12033053431 011616 0ustar00nmhnmh000000 000000 ____ ____ ____ ____ ____ / ___)/ __ \| __)| __)/ ___) Scheme 9 from Empty Space \___ \\__ /| __)| __)\___ \ Yet another implementation (____/(___/ |_| |____)(____/ of an interesting language This branch of S9fES is a hack. When something is broken or missing, fix it. Do with the code whatever you want, it is neither "mine" nor "yours". Rip it apart, make something new out of it, claim it is yours, re-license it, sell it, give it away, do not even tell me about it. This is all fine by me. Freedom cannot be possessed. Wherever there is freedom, it belongs to all. Being a hack, in this case, does not mean that the code is fragile. Au contraire. The S9 interpreter has been running large amounts of code for very long times without breaking, and I trust it to run even the most critical programs. It does mean, though, that when it *does* break, you are on your own. I have been hacking it for fun and may or may not consider fixing any bugs reported to me. Nils M Holm s9/s9.scm000644 001751 001751 00000052000 12075004455 012057 0ustar00nmhnmh000000 000000 ; DO NOT EDIT THIS FILE! EDIT "edoc/s9.scm.edoc" INSTEAD. ;; ;; Scheme 9 from Empty Space ;; By Nils M Holm, 2007-2010 ;; Placed in the Public Domain ;; ;; Some obvious procedures first (define (void) (if #f #f)) (define call-with-current-continuation call/cc) ;; Auxiliary definitions, will be redefined later (define append append2) ; There is no LET or LETREC yet, so (define-syntax (let bindings . exprs) ((lambda (split) ((lambda (tmp-split) (set! split tmp-split) (apply (lambda (vars args) (append (list (append (list 'lambda) (append (list vars) exprs))) args)) (split bindings '() '()))) (lambda (bind* vars args) (if (null? bind*) (list vars args) (split (cdr bind*) (cons (caar bind*) vars) (cons (cadr (car bind*)) args)))))) #f)) (define (map-car f a) (let ((mapcar1 #f)) (let ((tmp-mapcar1 (lambda (a) (if (null? a) '() (cons (f (car a)) (mapcar1 (cdr a))))))) (set! mapcar1 tmp-mapcar1) (mapcar1 a)))) (define (map f a b) (let ((map2 #f)) (let ((tmp-map2 (lambda (a b) (if (null? a) '() (cons (f (car a) (car b)) (map2 (cdr a) (cdr b))))))) (set! map2 tmp-map2) (map2 a b)))) (define-syntax (letrec bindings . exprs) (let ((append3 (lambda (a b c) (append a (append b c)))) (tmps (map-car (lambda (x) (gensym)) bindings)) (vars (map-car car bindings)) (args (map-car cadr bindings))) (let ((undefineds (map-car (lambda (v) (list v #f)) vars)) (tmp-bindings (map list tmps args)) (updates (map (lambda (v t) (list 'set! v t)) vars tmps))) (list 'let undefineds (append3 '(let) (list tmp-bindings) (append updates exprs)))))) ;; Type predicates (define number? integer?) (define (port? x) (or (input-port? x) (output-port? x))) ;; Equivalence predicates (define (equal? a b) (cond ((eq? a b)) ((and (pair? a) (pair? b)) (and (equal? (car a) (car b)) (equal? (cdr a) (cdr b)))) ((string? a) (and (string? b) (string=? a b))) ((vector? a) (and (vector? b) (equal? (vector->list a) (vector->list b)))) (else (eqv? a b)))) ;; List procedures (define (list? x) (letrec ((l? (lambda (x y) (cond ((eq? x y) #f) ((null? x) #t) ((pair? x) (or (null? (cdr x)) (and (pair? (cdr x)) (l? (cddr x) (cdr y))))) (else #f))))) (or (null? x) (and (pair? x) (l? (cdr x) x))))) (define (assoc x a) (cond ((null? a) #f) ((equal? (caar a) x) (car a)) (else (assoc x (cdr a))))) (define (member x a) (cond ((null? a) #f) ((equal? (car a) x) a) (else (member x (cdr a))))) ; Auxiliary functions for FOLD-LEFT, FOLD-RIGHT, MAP (define (map-car f a) (letrec ((mapcar1 (lambda (a r) (if (null? a) (reverse! r) (mapcar1 (cdr a) (cons (f (car a)) r)))))) (mapcar1 a '()))) (define car-of (let ((map-car map-car)) (lambda (a*) (map-car car a*)))) (define cdr-of (let ((map-car map-car)) (lambda (a*) (map-car cdr a*)))) (define (any-null a*) (memq '() a*)) (define fold-left (let ((car-of car-of) (cdr-of cdr-of) (any-null any-null)) (lambda (f b . a*) (letrec ((fold (lambda (a* r) (if (any-null a*) r (fold (cdr-of a*) (apply f r (car-of a*))))))) (if (null? a*) (error "fold-left: too few arguments") (fold a* b)))))) (define fold-right (let ((car-of car-of) (cdr-of cdr-of) (any-null any-null) (map-car map-car)) (lambda (f b . a*) (letrec ((foldr (lambda (a* r) (if (any-null a*) r (foldr (cdr-of a*) (apply f (append2 (car-of a*) (list r)))))))) (if (null? a*) (error "fold-right: too few arguments") (foldr (map-car reverse a*) b)))))) (define append (let ((append2 append2)) (letrec ((foldr-app (lambda (a) (cond ((null? a) '()) ((and (pair? a) (not (pair? (car a))) (null? (cdr a))) (car a)) (else (append2 (car a) (foldr-app (cdr a)))))))) (lambda a (foldr-app a))))) (define (list-ref x n) (car (list-tail x n))) (define map (let ((car-of car-of) (cdr-of cdr-of) (any-null any-null)) (lambda (f . a*) (letrec ((map2 (lambda (a* r) (if (any-null a*) (reverse! r) (map2 (cdr-of a*) (cons (apply f (car-of a*)) r)))))) (if (null? a*) (error "map: too few arguments") (map2 a* '())))))) (define (for-each f . a*) (if (null? a*) (error "for-each: too few arguments") (apply map f a*)) (void)) ;; Arithmetic procedures (define (expt x y) (letrec ((square (lambda (x) (* x x))) (expt2 (lambda (x y) (cond ((zero? y) 1) ((even? y) (square (expt2 x (quotient y 2)))) (else (* x (square (expt2 x (quotient y 2))))))))) (if (negative? y) (error "expt: expected non-negative exponent, got" y)) (expt2 x y))) (define gcd (let ((fold-left fold-left)) (lambda a (letrec ((gcd2 (lambda (a b) (cond ((zero? b) a) ((zero? a) b) ((< a b) (gcd2 a (remainder b a))) (else (gcd2 b (remainder a b))))))) (fold-left gcd2 0 (map abs a)))))) (define lcm (let ((fold-left fold-left)) (lambda a (letrec ((lcm2 (lambda (a b) (let ((cd (gcd a b))) (* cd (* (quotient a cd) (quotient b cd))))))) (fold-left lcm2 1 (map abs a)))))) (define (modulo a b) (let ((rem (remainder a b))) (cond ((zero? rem) 0) ((eq? (negative? a) (negative? b)) rem) (else (+ b rem))))) ;; String procedures (define (number->string n . radix) (letrec ((digits (string->list "0123456789abcdef")) (conv (lambda (n rdx res) (if (zero? n) (if (null? res) '(#\0) res) (conv (quotient n rdx) rdx (cons (list-ref digits (remainder n rdx)) res))))) (conv-int (lambda (n rdx) (if (negative? n) (list->string (cons #\- (conv (abs n) rdx '()))) (list->string (conv n rdx '()))))) (get-radix (lambda () (cond ((null? radix) 10) ((<= 2 (car radix) 16) (car radix)) (else (error "number->string: invalid radix" (car radix))))))) (conv-int n (get-radix)))) (define (string->number str . radix) (letrec ((digits (string->list "0123456789abcdef")) (value-of-digit (lambda (x) (letrec ((v (lambda (x d n) (cond ((null? d) 17) ((char=? x (car d)) n) (else (v x (cdr d) (+ n 1))))))) (v (char-downcase x) digits 0)))) (conv3 (lambda (lst res rdx) (if (null? lst) res (let ((dval (value-of-digit (car lst)))) (and (< dval rdx) (conv3 (cdr lst) (+ dval (* res rdx)) rdx)))))) (conv (lambda (lst rdx) (and (not (null? lst)) (conv3 lst 0 rdx)))) (sconv (lambda (lst rdx) (cond ((null? lst) #f) ((char=? (car lst) #\+) (conv (cdr lst) rdx)) ((char=? (car lst) #\-) (let ((r (conv (cdr lst) rdx))) (if r (- r) #f))) (else (conv lst rdx))))) (get-radix (lambda () (cond ((null? radix) 10) ((<= 2 (car radix) 17) (car radix)) (else (error "string->number: invalid radix" radix))))) (base-prefix? (lambda (s) (and (> (string-length s) 2) (char=? #\# (string-ref s 0)) (memv (string-ref s 1) '(#\b #\d #\o #\x)) #t)))) (let ((r (if (base-prefix? str) (let ((rc (string-ref str 1))) (cond ((char=? rc #\b) 2) ((char=? rc #\d) 10) ((char=? rc #\o) 8) (else 16))) (get-radix))) (s (if (base-prefix? str) (substring str 2 (string-length str)) str))) (and r (sconv (string->list s) r))))) ;; Input/output procedures (define (newline . port) (apply write-char #\newline port)) (define (call-with-input-file file proc) (let ((f (open-input-file file))) (let ((r (proc f))) (close-input-port f) r))) (define (call-with-output-file file proc) (let ((f (open-output-file file))) (let ((r (proc f))) (close-output-port f) r))) (define with-input-from-file (let ((set-input-port! set-input-port!)) (lambda (file thunk) (let ((outer-port (current-input-port)) (new-port (open-input-file file))) (set-input-port! new-port) (let ((r (thunk))) (close-input-port new-port) (set-input-port! outer-port) r))))) (define with-output-to-file (let ((set-output-port! set-output-port!)) (lambda (file thunk) (let ((outer-port (current-output-port)) (new-port (open-output-file file))) (set-output-port! new-port) (let ((r (thunk))) (close-output-port new-port) (set-output-port! outer-port) r))))) ;; Quasiquote Expander (define-syntax (quasiquote tmpl) (letrec ((qq-cons (lambda (a b) (cond ((and (pair? a) (eq? 'unquote-splicing (car a))) (list 'append (cadr a) b)) (else (list 'cons a b))))) (qq-expand-1 (lambda (x) (cond ((vector? x) (list 'list->vector (qq-expand-1 (vector->list x)))) ((not (pair? x)) (list 'quote x)) ((eq? 'unquote (car x)) (cadr x)) ((eq? 'unquote-splicing (car x)) x) (else (qq-cons (qq-expand-1 (car x)) (qq-expand-1 (cdr x))))))) (qq-expand (lambda (tmpl q) (let ((embedded-qq '())) (letrec ((extract-nested-qq (lambda (tmpl q) (cond ((not (pair? tmpl)) tmpl) ((or (eq? (car tmpl) 'unquote) (eq? (car tmpl) 'unquote-splicing)) (if (not q) (error "quasiquote: extra unquote/unquote-splicing")) (if (and (pair? (cdr tmpl)) (null? (cddr tmpl))) (list (car tmpl) (extract-nested-qq (cadr tmpl) #f)) (error (string-append (symbol->string (car tmpl)) ": wrong number of arguments") tmpl))) ((eq? 'quasiquote (car tmpl)) (if q (error "quasiquote: may not be nested")) (if (and (pair? (cdr tmpl)) (null? (cddr tmpl))) (let ((g (gensym))) (set! embedded-qq (cons (list g (qq-expand (cadr tmpl) #t)) embedded-qq)) g) (error "quasiquote: wrong number of arguments" tmpl))) (else (cons (extract-nested-qq (car tmpl) q) (extract-nested-qq (cdr tmpl) q))))))) (let ((tmpl (extract-nested-qq tmpl q))) (if (null? embedded-qq) (qq-expand-1 tmpl) (list 'let embedded-qq (qq-expand-1 tmpl))))))))) (qq-expand tmpl #t))) ;; Derived Syntax ; LET/LET*/LETREC helper (define (check-bindings who b opt-arg) (cond ((null? b)) ((and (pair? b) (pair? (car b)) (symbol? (caar b)) (pair? (cdar b)) (or (null? (cddar b)) (and opt-arg (pair? (cddar b)) (null? (cdddar b))))) (check-bindings who (cdr b) opt-arg)) (else (error (string-append who ": invalid syntax") b)))) (define (split-bindings clauses) (letrec ((split3 (lambda (clauses vars args opt) (cond ((null? clauses) (list (reverse! vars) (reverse! args) (reverse! opt))) (else (split3 (cdr clauses) (cons (caar clauses) vars) (cons (cadar clauses) args) (if (null? (cddar clauses)) (cons (caar clauses) opt) (cons (caddar clauses) opt)))))))) (split3 clauses '() '() '()))) ; Now that the QQ expander is here, define a ; clean version of LET (including named LET). ; Can't name it LET yet, because it uses LET. (define-syntax %full-let (let ((check-bindings check-bindings) (split-bindings split-bindings)) (lambda (a1 a2 . a3) (if (symbol? a1) (if (null? a3) (error "named let: missing body" `(let ,a1 ,a2 ,@a3)) (begin (check-bindings "let" a2 #f) (let ((va (split-bindings a2))) (let ((v (car va)) (a (cadr va))) `((letrec ((,a1 (lambda ,v ,@a3))) ,a1) ,@a))))) (begin (check-bindings "let" a1 #f) (let ((va (split-bindings a1))) (let ((v (car va)) (a (cadr va))) `((lambda ,v ,a2 ,@a3) ,@a)))))))) (define-syntax let %full-let) ; Also define a clean version of LETREC. (define-syntax %clean-letrec (let ((check-bindings check-bindings) (split-bindings split-bindings)) (lambda (bindings expr . exprs) (check-bindings "letrec" bindings #f) (let ((va (split-bindings bindings))) (let ((tmps (map (lambda (x) (gensym)) bindings)) (vars (car va)) (args (cadr va))) (let ((undefineds (map (lambda (v) (list v #f)) vars)) (tmp-bindings (map (lambda (t a) (list t a)) tmps args)) (updates (map (lambda (v t) (list 'set! v t)) vars tmps))) `(let ,undefineds (let ,tmp-bindings ,@updates ,expr ,@exprs)))))))) (define-syntax letrec %clean-letrec) (define-syntax let* (let ((check-bindings check-bindings)) (lambda (bindings expr . exprs) (letrec ((nest-let (lambda (b) (cond ((null? b) (cons expr exprs)) ((null? (cdr b)) `(let ((,(caar b) ,(cadar b))) ,@(cons expr exprs))) (else `(let ((,(caar b) ,(cadar b))) ,(nest-let (cdr b)))))))) (check-bindings "let*" bindings #f) (if (null? bindings) `(let () ,expr ,@exprs) (nest-let bindings)))))) (define-syntax (case key . clauses) (letrec ((gen-clauses (lambda (k c*) (cond ((null? c*) '()) ((or (not (pair? c*)) (not (pair? (car c*))) (not (pair? (cdar c*)))) (error "case: invalid syntax" c*)) ((null? (cdr c*)) (if (eq? 'else (caar c*)) `((else ,@(cdar c*))) `(((memv ,k ',(caar c*)) ,@(cdar c*))))) (else `(((memv ,k ',(caar c*)) ,@(cdar c*)) ,@(gen-clauses k (cdr c*)))))))) (let ((k (gensym))) `(let ((,k ,key)) (cond ,@(gen-clauses k clauses)))))) (define-syntax do (let ((check-bindings check-bindings) (split-bindings split-bindings)) (lambda (var-clauses test . body) (if (or (not (pair? test)) (not (list? (cdr test)))) (error "do: invalid syntax" test)) (check-bindings "do" var-clauses #t) (let ((loop (gensym)) (var+init+step (split-bindings var-clauses))) (let ((v (car var+init+step)) (i (cadr var+init+step)) (s (caddr var+init+step))) `(letrec ((,loop (lambda ,v (if ,(car test) (begin ,@(cdr test)) (begin ,@body (,loop ,@s)))))) (,loop ,@i))))))) (define-syntax (delay expr) `(let ((value #f)) (lambda () (if value (car value) (let ((x ,expr)) (if value (car value) (begin (set! value (list x)) (car value)))))))) (define (force x) (x)) ;; Utilities (define (print . x*) (letrec ((p (lambda (x* first) (cond ((not (null? x*)) (if (not first) (write-char #\space)) (write (car x*)) (p (cdr x*) #f)))))) (p x* #t) (newline))) (define (locate-file file) (letrec ((split (lambda (s) (let loop ((in (string->list s)) (tmp '()) (out '())) (cond ((null? in) (if (null? tmp) out (reverse! (cons (list->string (reverse! tmp)) out)))) ((char=? #\: (car in)) (loop (cdr in) '() (cons (list->string (reverse! tmp)) out))) (else (loop (cdr in) (cons (car in) tmp) out))))))) (let loop ((path (split *library-path*))) (and (not (null? path)) (let ((full-path (string-append (car path) "/" file))) (if (file-exists? full-path) full-path (loop (cdr path)))))))) (define load-from-library (let ((locate-file locate-file)) (lambda (file) (let ((full-path (locate-file file)) (do-load (lambda (file) (begin (if (not *loading*) (begin (display "; loading from ") (display file) (newline))) (load file))))) (if full-path (do-load full-path) (let ((full-path (locate-file (string-append file ".scm")))) (if full-path (do-load full-path) (error "cannot locate file" file)))))))) (define-syntax (require-extension . x*) (do ((x* x* (cdr x*)) (na '())) ((null? x*) (if (not (null? na)) (error "extension(s) required, but not compiled-in" (reverse! na)))) (if (not (memq (car x*) *extensions*)) (set! na (cons (car x*) na))))) s9/s9-real.scm000644 001751 001751 00000041671 12036216753 013017 0ustar00nmhnmh000000 000000 ; DO NOT EDIT THIS FILE! EDIT "edoc/s9-real.scm.edoc" INSTEAD. ;; ;; Scheme 9 from Empty Space, real number arithmetics ;; By Nils M Holm, 2007-2010 ;; Placed in the Public Domain ;; (require-extension realnums) ; Some of these procedures redefine those in "s9.scm" (define number? real?) (define (expt x y) (letrec ((square (lambda (x) (* x x))) (expt2 (lambda (x y) (cond ((zero? y) 1) ((even? y) (square (expt2 x (quotient y 2)))) (else (* x (square (expt2 x (quotient y 2))))))))) (cond ((negative? y) (/ (expt (exact->inexact x) (- y)))) ((integer? y) (expt2 x y)) (else (exp (* y (log x))))))) (define (ceiling x) (- (floor (- x)))) (define (round x) (let ((x+ (+ 0.5 x))) (let ((rx (floor x+))) (if (and (odd? (inexact->exact rx)) (= x+ rx)) (- rx 1) rx)))) (define (truncate x) ((if (< x 0) ceiling floor) x)) ; used by SIN, COS, ATAN, and EXP (define (fact2 n m) (if (< n 2) m (let ((k (quotient n 2))) (* (fact2 k m) (fact2 (- n k) (+ m k)))))) (define exp (let ((fact2 fact2)) (lambda (x) (letrec ((e-series (lambda (x y r last) (if (= r last) r (e-series x (+ 1 y) (+ r (/ (expt x y) (fact2 y 1))) r))))) (if (>= x 2.0) (let ((e^x/2 (exp (/ x 2)))) (* e^x/2 e^x/2)) (+ 1 x (e-series x 2 0.0 1.0))))))) (define (log x) (letrec ((l-series (lambda (x y r last lim) (cond ((and lim (zero? lim)) r) ((= r last) (* 2 r)) (else (l-series x (+ 2 y) (+ r (/ (expt (/ (- x 1) (+ x 1)) y) y)) r (if lim (- lim 1) lim))))))) (cond ((negative? x) (/ 1.0 0)) ((< 0.1 x 5) (l-series x 1 0.0 1.0 #f)) (else (let ((approx (l-series x 1 0.0 1.0 5))) (let ((a (/ x (exp approx)))) (+ approx (log a)))))))) ; auxiliary definitions for SIN, COS, TAN, ATAN (define pi 3.141592653589793238462643383279502884197169399375105820974944) (define pi/4 (/ pi 4)) (define pi/2 (/ pi 2)) (define 3pi/4 (+ pi/2 pi/4)) (define 3pi/2 (+ pi pi/2)) (define 5pi/4 (+ pi pi/4)) (define 7pi/4 (+ pi 3pi/4)) (define 2pi (+ pi pi)) (define ->circle (let ((2pi 2pi)) (lambda (x) (let* ((x+ (abs x)) (d (* 2pi (floor (/ x+ 2pi)))) (x+ (- x+ d))) (if (negative? x) (- 2pi x+) x+))))) (define sine-series (let ((fact2 fact2)) (lambda (x y r add last) (if (= r last) r (sine-series x (+ 2 y) ((if add + -) r (/ (expt x y) (fact2 y 1))) (not add) r))))) (define cos (let ((->circle ->circle) (sine-series sine-series) (pi pi) (pi/2 pi/2) (3pi/2 3pi/2) (2pi 2pi)) (lambda (x) (let ((x (->circle x))) (cond ((= 0 x) (if (inexact? x) 1.0 1)) ((= pi/2 x) 0.0) ((= pi x) -1.0) ((= 3pi/2 x) 0.0) ((<= 0 x pi/2) (sine-series x 2 1.0 #f 0)) ((<= pi/2 x pi) (- (sine-series (- pi x) 2 1.0 #f 0))) ((<= pi x 3pi/2) (- (sine-series (- x pi) 2 1.0 #f 0))) (else (sine-series (- 2pi x) 2 1.0 #f 0))))))) (define sin (let ((->circle ->circle) (sine-series sine-series) (pi pi) (pi/2 pi/2) (3pi/2 3pi/2) (2pi 2pi)) (lambda (x) (let ((x (->circle x))) (cond ((= 0 x) (if (inexact? x) 0.0 0)) ((= pi/2 x) 1.0) ((= pi x) 0.0) ((= 3pi/2 x) -1.0) (else (let ((z (cond ((<= 0 x pi/2) x) ((<= pi/2 x pi) (- pi x)) ((<= pi x 3pi/2) (- x pi)) (else (- 2pi x))))) (if (> x pi) (- (sine-series z 3 z #f 0)) (sine-series z 3 z #f 0))))))))) (define tan (let ((->circle ->circle) (pi pi) (pi/4 pi/4) (3pi/4 3pi/4) (5pi/4 5pi/4) (7pi/4 7pi/4)) (lambda (x) (let ((x (->circle x))) (cond ((or (= x 0) (= x pi)) (if (inexact? x) 0.0 0)) ((or (= x pi/4) (= x 5pi/4)) 1.0) ((or (= x 3pi/4) (= x 7pi/4)) -1.0) (else (/ (sin x) (cos x)))))))) (define atan (let ((pi/2 pi/2)) (letrec ((at-series (lambda (x y r last) (if (= r last) r (at-series x (+ 1 y) (+ r (* (/ (* (expt 2 (+ y y)) (expt (fact2 y 1) 2)) (fact2 (+ y y 1) 1)) (/ (expt x (+ y y 1)) (expt (+ 1 (* x x)) (+ 1 y))))) r))))) (lambda (x) (cond ((negative? x) (- (at-series (- x) 0.0 0 1))) ((> x 1) (- pi/2 (atan (/ x)))) (else (at-series x 0.0 0 1))))))) (define (asin x) (cond ((= 1 x) (* 2 (atan x))) ((negative? x) (- (asin (- x)))) (else (atan (/ x (sqrt (- 1 (* x x)))))))) (define acos (let ((pi pi) (pi/2 pi/2)) (lambda (x) (cond ((= -1 x) pi) ((= 1 x) 0) (else (- pi/2 (asin x))))))) (define (sqrt square) (letrec ((sqrt2 (lambda (x last) (if (= last x) x (sqrt2 (/ (+ x (/ square x)) 2) x))))) (if (negative? square) (error "sqrt: negative argument" square) (sqrt2 square 0)))) ; Used by NUMBER->STRING and STRING->NUMBER (define (number-of-digits n r) (if (zero? n) (if (zero? r) 1 r) (number-of-digits (quotient n 10) (+ 1 r)))) (define number->string (let ((number-of-digits number-of-digits)) (lambda (n . radix) (letrec ((digits (list->vector (string->list "0123456789abcdefghijklmnopqrstuvwxyz"))) (conv (lambda (n rdx res) (if (zero? n) (if (null? res) '(#\0) res) (conv (quotient n rdx) rdx (cons (vector-ref digits (remainder n rdx)) res))))) (conv-int (lambda (n rdx) (if (negative? n) (list->string (cons #\- (conv (abs n) rdx '()))) (list->string (conv n rdx '()))))) (conv-sci-real (lambda (m e) (let ((m-str (conv-int m 10)) (e-str (conv-int e 10)) (i (if (negative? m) 2 1))) (let ((k (string-length m-str))) (string-append (substring m-str 0 i) "." (if (= k i) "0" (substring m-str i k)) "e" (if (>= e 0) "+" "") e-str))))) (zeroes (lambda (n) (let loop ((n n) (z '())) (if (positive? n) (loop (- n 1) (cons #\0 z)) (list->string z))))) (conv-expanded-real (lambda (n expn digits) (let ((m (abs n)) (offset (+ expn digits))) (string-append (if (negative? n) "-" "") (cond ((negative? offset) "0.") ((zero? offset) "0") (else "")) (zeroes (- offset)) (let ((m-str (conv-int m 10))) (if (<= 0 offset digits) (string-append (substring m-str 0 offset) "." (substring m-str offset digits) (if (= offset digits) "0" "")) m-str)) (if (> offset digits) (string-append (zeroes (- offset digits)) ".0") ""))))) (conv-real (lambda (n) (let ((m (mantissa n)) (e (exponent n))) (let ((d (number-of-digits m 0))) (if (< -4 (+ e d) 10) (conv-expanded-real m e d) (conv-sci-real m (+ e d -1))))))) (get-radix (lambda () (cond ((null? radix) 10) ((<= 2 (car radix) 36) (car radix)) (else (error "number->string: invalid radix" (car radix))))))) (let ((r (get-radix))) (cond ((not (or (exact? n) (= 10 r))) (error "number->string: real number needs a radix of 10" n)) ((exact? n) (conv-int n r)) (else (conv-real n)))))))) (define string->number (let ((number-of-digits number-of-digits) (make-inexact #f) (make-exact #f)) (lambda (str . radix) (letrec ((digits (string->list "0123456789abcdefghijklmnopqrstuvwxyz")) (value-of-digit (lambda (x) (letrec ((v (lambda (x d n) (cond ((null? d) 36) ((char=? (car d) x) n) (else (v x (cdr d) (+ n 1))))))) (v (char-downcase x) digits 0)))) (exponent-mark (lambda (c) (memv c '(#\d #\D #\e #\E #\f #\F #\l #\L #\s #\S)))) (make-result cons) (value car) (rest cdr) (FAILED '(#f . #f)) (failed? (lambda (res) (eq? #f (cdr res)))) (ok? (lambda (res) (not (eq? #f (cdr res))))) (conv3 (lambda (lst val rdx) (if (null? lst) (make-result val '()) (let ((dval (value-of-digit (car lst)))) (if (< dval rdx) (conv3 (cdr lst) (+ (value-of-digit (car lst)) (* val rdx)) rdx) (make-result val lst)))))) (conv (lambda (lst rdx) (if (null? lst) FAILED (conv3 lst 0 rdx)))) (conv-int (lambda (lst rdx) (cond ((null? lst) FAILED) ((char=? (car lst) #\+) (conv (cdr lst) rdx)) ((char=? (car lst) #\-) (let ((r (conv (cdr lst) rdx))) (if (ok? r) (make-result (- (value r)) (rest r)) FAILED))) (else (conv lst rdx))))) (make-frag (lambda (x) (let ((d (number-of-digits x -1))) ; 123 --> 0.123 (- (/ x (expt 10.0 d)) 1.0)))) (make-real (lambda (int frag expn) (let ((v (* (+ 0.0 (abs int) (make-frag frag)) (expt 10.0 expn)))) (if (negative? int) (- v) v)))) (conv-exponent (lambda (int frag lst) (if (null? lst) FAILED (let ((exp-part (conv-int lst 10))) (if (failed? exp-part) FAILED (make-result (make-real int frag (value exp-part)) (rest exp-part))))))) (conv-decimals (lambda (int lst) (cond ((null? lst) (make-result (exact->inexact int) '())) ; trailing #\. ((exponent-mark (car lst)) (conv-exponent int 10 (cdr lst))) (else (let ((frag-part (conv3 lst 1 10))) (if (null? (rest frag-part)) (make-result (make-real int (value frag-part) 0) '()) (if (exponent-mark (car (rest frag-part))) (conv-exponent int (value frag-part) (cdr (rest frag-part))) FAILED))))))) (assert-radix-ten (lambda (rdx) (cond ((= 10 rdx)) ((null? radix) #f) (else (error (string-append "string->number: real number" " needs a radix of 10")))))) (mantissa? (lambda (x) (cond ((null? x) #f) ((char-numeric? (car x)) #t) ((exponent-mark (car x)) #f) (else (mantissa? (cdr x)))))) (conv-real (lambda (lst rdx) (let ((int-part (conv-int lst rdx))) (cond ((failed? int-part) FAILED) ((and (zero? (value int-part)) ; "" or "e" (not (mantissa? lst))) FAILED) ((null? (rest int-part)) int-part) ((exponent-mark (car (rest int-part))) (assert-radix-ten rdx) (conv-exponent (value int-part) 10 (cdr (rest int-part)))) ((char=? #\. (car (rest int-part))) (assert-radix-ten rdx) (conv-decimals (value int-part) (cdr (rest int-part)))) (else FAILED))))) (replace-inexact-digits! (lambda (a) (cond ((null? a)) ((char=? #\# (car a)) (set-car! a #\5) (set! make-inexact #t) (replace-inexact-digits! (cdr a))) (else (replace-inexact-digits! (cdr a)))))) (get-radix (lambda () (cond ((null? radix) 10) ((<= 2 (car radix) 36) (car radix)) (else (error "string->number: invalid radix" (car radix))))))) (set! make-inexact #f) (set! make-exact #f) (let ((radix (get-radix)) (lst (string->list str))) (if (and (> (string-length str) 1) (char=? #\# (car lst))) (let ((mod (cadr lst))) (set! lst (cddr lst)) (cond ((char=? mod #\d)) ((char=? mod #\e) (set! make-exact #t)) ((char=? mod #\i) (set! make-inexact #t)) ((char=? mod #\b) (set! radix 2)) ((char=? mod #\o) (set! radix 8)) ((char=? mod #\x) (set! radix 16)) (else (set! lst '()))))) (if (or (null? lst) (memv (car lst) '(#\+ #\- #\.)) (char-numeric? (car lst))) (replace-inexact-digits! lst)) (let ((r (cond ((null? lst) FAILED) ((char=? #\- (car lst)) (conv-real (cdr lst) radix)) (else (conv-real lst radix))))) (if (null? (rest r)) (let ((v (if (char=? #\- (car lst)) (- (value r)) (value r)))) (cond (make-inexact (exact->inexact v)) (make-exact (if (integer? v) (inexact->exact v) #f)) (else v))) #f))))))) s9/help/000755 001751 001751 00000000000 12245101210 011735 5ustar00nmhnmh000000 000000 s9/MASCOT.png000644 001751 001751 00000020671 12047673426 012536 0ustar00nmhnmh000000 000000 ‰PNG  IHDR^‘“ÛKPLTEèàÀ€ìQŠÙ pHYs  ÒÝ~ü ®IDATxÚíœ}\UúèŸÉ„™Ð†L(Ý:)) /…z·ÚðbZJT ++Uïçnwíj(Ýݾ„â­°"Lª)¤ÔÛ¦ j×ÝýíÞµ¨këÚ• TšBëúÙ¥nµ@Ð]uCq5ع“7(a õŸß÷³ósÎÉùÎsÎóœ·çÌþsýçúÏõßz©X–¥1|HÃ!ìwƒ²“4Î:‘ï€ÔN y,h¿ƒ)÷a™Û¢pún„û;”‹ Üo PWPÚm—Œpëäê6Ë5òÜ®×LHq›BpçL`„ß¡*â@enëÒøJSò]*ã²QÜLùn þBÒÒÛ©=}‚0ù·›(¥à6Íþ›Ò«¾º<>'–)ºm…ͳîÖỂÖÛVØOà»D57Á™pK$&$áÜ­µœÏüÞ-gHüÖ­,+ ­Ûükž†ð[j }(Jß !nY¹yWļý-*f^R¥ôLÆm¤„\»ç¥ÄÜ ùt^Ê­l‰Ì×ÏRê3/ ¿E'ã,©} ½8‚S`¾µà9gü¦Ð´‰Å ÀöÐ4ç∜§‹#yÒna~¾Ÿå‹#7—*hvÉâsSX¸ã‹ʯ‚!i+õÚm!7™- ¹D¨Ez&¨Åß „ÐE‘›~•ïŸÿœÅ‘;Lº`pQ䦚.“ì ™£ÆÅH¨ Ef¬†ÀæÆ™œóvéªVL¿(.$-®’+Cä¸Öw3J1Ô¥¨CHK @Ãr°ÂÒE›²z¦;!òy (Z ¤ëƒ pŒBÞ &/:^ÆÎ °±ê"\´Ã”tÌ”,}p (p1díÏu%‹(â©ìR¥ÒWÜÅ:Œ0ÔÔK_nÝqJ­ÄnôÑ~éb‡jþæ« ‚¢‹!CägSµœËó0íW7Z¿0Bšýµ£âÏåÉ7»ý"‹ ²3VÒx¬‘ªÞéOî¡FÂõ‚Ýám,¸üçÊ["wê|ˆö$€`9»|©ÚzaDÊø¤-JȎÕپhÖbÈ'þñp•´5 ù“‹è¦Õ;³÷nì•`8DƒÔ‡0Ê‘8Jé«©á¢4¹Ú•~DÉ` "ñŒw²€¡·Dq ¥–2¶p]⇄~¤ÎÈú½«„>D½náúÇ“¾µ§!LL\^_òjo”Tís.ˆ ßS1þ»ËIÚj¡-è,is|úÔ^¢`Ęv}@‘ªÌ…\2QŽO"ˆ4™VUõa´Ôß|TRb!)€¨ü˜šÂ*½ˆßßY.Å/Žpu!ê–Mµìû"0æ­¢ © öß9µ5ÞxàÚ—gÌ ×@_+ƒˆ¢ó%¹† †\ZÉH( òMoRÄ;þrŠV¨”ºU‚_Êœh?gºH«|›%¢ÉÔù=i…§½UܨxþÐ+nF.ä$R°Boó»$Z†4À[^¤’J=}è¾çoP¾zÁ²‡eoç#_à²Õ3BÙù©ß%y7rýȆ¬Â!²Ê‡ŸŸØ·6‘óÆ·x5ÐBñ›å $S´wïA~z‚¨ˆ¥|H7¿äð۲Ѽ’Ÿõ!€üþéDy¤ÿÑœ ‡áEp³Tø² ;D¬è }ÍRÌ!ÝN^$Â,DÿùÚ ÄS KÎh/¢KM(ì_# ïU¾‹ýƇìRÀý¬’×0ò8NCq:‚JØwÄ_0©øP­%CʇlŽçš}ŠÖ¯ð/ÁþÉc”Q ?²2ü³²ú^º[›°Ñ®¬¦_¶ø—È*䊕á/—© í4(Ñ”öÓ>DŠôçáíÊ‚ çCÆ)ý±×¿O—Ö‹PªØ¾‚ë¿æ0°j XG)k?Ýß ò“cOŒ•ñIÁ£Ü"«#«q~îW…¯r>Iñ §«ÍW)ipA•È°“áŒÈ°ïÒU4"tXžAŽ c’?[9:ý•wÙa¥/Ò– ]öyzdW¿.h6;–Ì'EôÝsaȈW½™aô™<ÛïÙ©bx¸í9ž-}Ò@LV{cDˆøb;ójJGÄ;yR:g¬dFü»é/ñ*Œ^` Jï(¹-ùs±˜Ñ‹R›Ò|Ápì¤#Nø vˆdecè ž]¯’M’š8ÊŒ¯óLŸð•mJgåû §x¤ì¾Ñq"` p?úŠç_‡•Þ1¥_“OЯð!GßMi}A-hº¦¦¿ð¯zQiQ¤†jœOsÄ Ù›þùääôÔŸ}»‘J9…ÅPIç! Ûb«,þ‚ •0ë÷ÿ\e;…ÞE½À³¹°_¢p`B¯rƒÕ„ÖS¨ØÙIÍ#Di„¤r4áÖ»lUúxë)¤þ ’¹NrwI0†ˆtØzÿVPd=%jFÎ_ùf3Dó]Pܬ’6 RïtŸŸe}[üW;w)xŒh^D8Fçß| Òœ‘W0]/RÔÒ›”<ƒ¬q}È{g'3Zö‹†òºùÞ%’¢¼öë¤ô`m>$²pS8—O‰í­Âô@éB)ÛÒÓ8Ó)A“é@×Íê…;R*Ø9¤³Ñ†Ïö#ªÜÀ5÷1n,”·¦S¨‘”yÈ Gl#Çg÷O–ïÅ0øŠÞH‘õÉÎÌÂq´ÍÄ…MHÝŸ|j]öO©4ÏCÚ/Lfçªç2d'  H÷.¯,´|qeBi'&Ûí3ñÁPT6 Üê-IÛ]ÖÞW0oÝœÙâœ0šfâZyÔW‡)ø-Ð?Ê ˆ‹}b*A¯ïpOg¥ÜõÁÎû¹'ÉÑnuÁ>›­Î9OÊð]UÿìŒÐŽÆ{ïkŒ"Ý÷¾Ôxn+ÔVÒ×1¢$õ>ßpç“è/!#ï¿´còöá¹5ø*ŒDŒ–Aߪ}™˜„’KY“4ÎûÐkS Âà_Ž¦%N¦÷yƒñ0ØåG'Øžy;þhwå…kw‚‰ßg€l(»|òŠkd[(‚wã_æbáðGú”ˆÒ[ânغMdù—y^ƒÉ;Žz¢Œ5­ñ÷üeH/,‘.ß^Û¤œ‡üm-nø•?²³]’ž@s'% ¢¤wVËÜóf‹Æ“5¨õQ¿‰ïpÇíDã¶b:¯ƒLBQÚRM›gӲк´Ü­É²ÖÒþXiSS2ªôn—d%I‘ëÖD7gfΫ~xs´ãý#´OŒb›b+îÑz§1! múµc›ï­ *nQT“~·z_røsŹ§ËD‰uh‹´yÝÖ>Ï.͸º"݇([ŸÎ0ñÊ&u(Þ¹7ÎÓЫ EŸé=ºŠï`ü'£´òo´(cIIº²œ±P7u­e±«z_d¹b7¢‡µ^Ä ’”˜Ž) EÈ$¨)ÛáE¸5!©ŒÜÈS(H4mïc!HÜ*­P]{UÅ) Ù†P€Àžbß„¡Í ž.¦ÑŒÍ±¡uI>ŠW¹®zÇ‹ÆIõ·O¹§|H]eájåLhÁÎÈÅïøŸðßI£"¢.y9®/:´¹@†"/ˬø˜œàf£DåO!‰[K=µß§ŒG¢ÄÑ÷Š“Ô…JIltÀsrœÒÂÝJ¬ãVŒÊo&ÑvZ’XælœéC-‰„«?ªŽëW¢®Q †.Y¬YîU™ÂBKðqGü7”Ͻêq•§ZÕitséb܇ÆeGz½*ÄB ã‡{سgBÂäOkFc÷EZÝ:Í·4ž‹Æ ¾âÚ5Ždr.ê–•YŸ„…J1é3$ŽÑ³Òᩃ®l‹î¥e0mQ5t´.Ûº­.¬”ãåÿ'½_®ÇtJEãu†LÎ%YSͨšCp*]5H&= w)¦û©\R&4¦‹Až#êÖo°„:ð ˆe ¥Sä¦çùèT:•KÃÛ²pgršÛªúÞ<„‰ÝÅ´‹ŒD g´ˆ‘\‚ôü‡™ð‡ÖB„P—zFþÏ»C¹¥Aó~jŸ)ÚfÌèò b/òžöG 3*ÀT×Ó„úÜd ™uëhZÐha4h5“p=-Ú.–/5&9ªËÞq¨VIJ­&ܺãctÂgGø”)9Fú=d…+FP89˜L ÒM;ÙÌ^RB SBT‹{I@NŠ6%tûRókU¬El;¶ÖÅiLH<¶‡.ØÎ-{#67²cG©¹gÚM´Â(Õ·Þ´´(œ†X4,Äù@}xHN°®#!¶–r5`)®µ7)Ð] BÐ:ô(Ý ð!aÑ0WªB ÈSZ”TÔ¿MÊñÏIÀplËORt/–€v%jb”Û·Ò!½’sÆÞü¼ÖBä×°CŽ=I¢¡J…Ó«¤/skä0è éÄ(BÚª„“–%¢fÏ·¤Ü·¹–œ¥9J9‡;ìcœÞ÷µv.Â_mŸÕHcDy®˜$9Üò»79Õ%ZÈŒüwLžR"Qá™E™:’$Ú3¯ˆÅ¾_÷MÚF^x½ƒký¯« qÌ­?z~ù3UŸteY»<_(öøòǶuw^g¸ñ6%6½ëž¬¬ƒÔ©Ã%Ÿù<-ÉpO¬Oø¨Íºvc È•=Ç]©‡C_²Y„뫨°Kä æsZLöÅN¯ ˜qñ"uúÁ ÖV$SÅ'ûæáfai9c§D©IgŒŒY hËíƒï˜?–­‰ø©ÆTGÈÂùvå±W°…×u!…Øß­Nù5gçXÙødèI¤†ŸMRä1Í·Šæû—€j­`šrâ.37˜‘)6*Dɲ&ѧÝÂR¥|êÔ“ O4ñK1HG»sb[J†¸¦‘¯9á¦çÊñˆéÜ„žÛ4è‘IpîW¯}©ä¾C€SrÎ|;{uî‘¢Ó½#ÉÒúXÌ#ѲLñA*Þ‰Üx­ô¹ïzië+ÕöQvŽ£Û¡†3{uDº ¦ü¤l}Â3PrÒͪ¿ŒäÇôýŵ"~ŽùcO«*¬¤¹„Œx:ãÇ×Ò3“ºa46¿¯î,˜ÎÝÔø» eê è5a)![27U§gÞ= ë©óW2”Èÿöì†æoG0sÚ©9;f´—¨‘„ýzYÀ(•²l}£µênÈÿEL‘â‰v㜃¤6öø°Þ”¸žHWoýLúL2Õ¶µù'O¬UBAÏú(áºt3"X¾¹±e$[÷—Ç¿™]å Ü©½;ì–¨ô7ªe»ó[L윆)È7‘kqÈèOØ¿=Ô«þEG ÜWÒ'¸·‚[mU˜JlìÍœc¨ë˜Šlcþæ…]Ó7¼¥ßWj‡-©\OþJ<–0bÉÍæGOxV4v!Û7ê¢:š_°³†óÊ»Jï‹M;ÊØ»OüAÉHGæ þxÔ4ë –.@ÎýRu¸1½ŸÒ‡©’äĦü…÷Hë1®¢æ(“­”âÒUºž¯©Nž¾Pi„ÇÃTØúýw“p½­ð䯮S™s^Ãb:«é{¡ì@åÄ>»`ýj'v]¿’%±ÁÖ/j¾ÝœÚs³ù± Í gf½%+aúX•Iµ 6¬ëˆz¸z¢kŠ‰¶µ©&z¦nÞðÇ&ÞBLïK¾A§›^å¾ÆŽè õšpR ™³[Uá »F:‹l):O>óýxNiÔ7 釯k!ýÈö¥W,‚p Ÿ½ñ^úxå‰gÑ›v<›†¿ ¯¥i]ä}yWê!‰<²=¼­]÷‡ Ÿ¥õ.­ŒÈnê1ȸà Xí¤·–~릚^¥aÙKî°†GËÈú?É*%û½IeèÇIÏêåçèŸÞ÷çÃ¥š®Ó@Žx^¨&¸¡²Z÷_ÛÅ9Ëœ¬/É<NºŠ”~“BMÓ pŒ¦±BÏ÷wÓiyý‰lIaæó75I„iºEh®êk{žý&§q-gŒ,fÿ8þíJ;'e çZ£.ü&í¦£~Ôûy1 Ù©³Ë<ÿü˜5Q 3ï–Ö Ëu úÒ˜„¾•ðU«G;ƒÍ2kWc»*[jX»¬ÍEAøï¯/ÿz½C’ p.ed||éj[“Æ5c™•ÙÕ…SÎl]Yc<;-$(Î~ønO8›((kæ2õ¿ZüÉ[+mPÓiùÁ‰:}›R·Ãj§6Ù,$çO·­¸ë³³‚âFÀ•á_è–*ªif‘ÁzL'Qëv¥C<Ž“œ¦‘æÿ…u@;_(7þⱃÓÇßдÏh9zÌ8.ÒU fq8N¶qˆíAfä!U‹ êµÿÒ¼vÇ“ã)³'*—%¬µˆMÙ`)²èeÞÝ¥ËwAfì|¯ ý¹;ðy…Ÿ6ÖÏXF¯¹6:>EÉ‹ÈXÄ»µE ¸9Ò9Á¹qÉý¿ñÈ]"™›°ßÃrƒ%“uŒu_¦É"s•á7ªjŸþFÅÔ‰ËS‡¹¹¤'L ç±°ÁŽÌA$íÜ®ÊZ×°v™î´ãL‘EÌ!ðd¹Ërt5WayQ‚öÆÇívKšÜ(KÖ?Å¿ÜŸ­:£9Slñy„±ákO< <ÃM¥¿=ØóÍ¢|eõnEpÿ8¹ü…LîÏ.Òõ¤ËS½ªü@ï!K—^^͹?„{¥¥…•S$þŠPšÖl½]Ý£*#SU^[}ÐþdïO’ŸïóniŸw–4 áZieIð ÀúVDáÐn«Ï^_&ÃëDÿ¸Å0)(M?aâºÓ•ŽXlyraçú™s«òÖ VMG½×*^?*/Ñsiù‡Žô¦–ª·r6B?ÿý] ERwÑ#†¿1¥qÆL©à=³¬7ísRTÎ¥í‘Z’¼•s)”îß®ù¾ó§`èd™ì²ê´Ø-’»•¶­ø€Þ.“]âÒrÅ=¿Œyu€ôÇÿºš²£š§‚/beUKÈÁ^°qCZÏx%cÉŸZ·OráÌ£íî™ËÀ¢¿ ®ýe„Pãä•ÏÚÊí+/²"vŒêOÙ˜äÝ‘}¿RÞ€’®"Á ÜhØ\KÏCõý®rS îUò2“¬mßÙßH¹0qlû"ÜÅB>Ûì•XªGL°óþ—/”›2«¼Ò‡¶­þ³´Ô» ’3bkÐװܘŒgŒÂÓ‰‰ Œ=HYju^D׉…#DÞ<ˆu@µ‚FgOm®\¥z[¶d'Ô®:GgYƼ;+¼[A˜oH|/øƒ3ˆ×X³Cß©²tZT‡ê Â="#¼[E˜s ÌEL¸¼ˆöú)F œ.ŽäQRᣪ$•e“/Ôx¥ æž æšõÌ3\Xˆ;{X „3<³JÈs¯ß;T!$¦#þÌNô¦dy«¼Í¹ qsŽoœw‡žp–h\».ÜxÁÃló>8SÕ~Üþ¯&æ Y'£†”tÖ`‰=“¦ Þ'ÈÅÒk_~Õ2Iû²d…Ô…B®_ª”FØ'3üžªx/¶ô×Mr ð]9½jдûENØlû3zý:‰W$¾ö™=FÇ‹d§]„<̦•‘TO…̱êm~¤®*Œ²' °© Ã?ŠàÒçâ,ÔBG»Pfˆó(úŒF’—<\ÝêK ‘É;¸¿>Q¸ƒ¾†œÊS|S}Ü—AfLPOQ?"Qî7!Î\šRLßn.ãff%BÚ[ì£r9Ò;šJWþ #˜'&ë%nFU|HåÜ6¦‘[m$£LãÌìH ÷ü„ûÕ‡ô–tôŒ*k.rLÓc›9•…¢‘‚SÁ×,QKÙ E#F¦ÿsÍ™fñ½¶`  f‘JñD/Ÿ] tX7уô_d­fr׌µñDyÛ²¹yMiYŸìªj7Rƒÿ’TL®™±¾%¡P7ß¹Fdh}º;½Ž ìZõàÑú;à?üA6·P*åCbÒÝÜ(v›õJê…™™ûá{߸àkzcä® ]5\‹“/Ïë\û±NÃ~ˇŒÅ`×ä%"dH•1&çt?Ž.Þ£pû QBžhÓˆû³ø¿Ÿ˜)pŸàÁdj3ïY¨Š¼ ¢M%ˆ:i«¶×^Ï"äCbWÆ >¤xdBqèYˆWÓöW>Y;‹@‚¤–ÔðjÝ q´›-\+0Ÿõì.›Ý{Q…ã-1|ˆBäjŽí|E;Róf‘¿"=EŽñ>ó+(Wcù»€ovö}&Ý áL¾[Bó!·mœ|´ÕJFäÜÞq“¥ÌÛÈnUýç…*S÷E锳I”ÂBKw\^½4V¦é» 2Z-^÷½‚U:8žÍóET¾¿,YD©d]M} ÂJ+•oxz¢ËÒÅÕ|…R"χó!ÞÖ…Ö^K2-à€Í·ó °EZŠE[#æžžóÏb¶‹.E´‡³{¶³ÞÝÙZo×ït–¹Ã‡>ßÿM|ûâ£ß>êïëߥa ¹Ê²Þ þ£—3W‹ñnúSÝéb ßZ\ë}X-k©_ÿ£KyŒL?W ^ëÿòÙè´•e'¤›¯>Y£»¶¥eU?Š¸y>@Y×ШŽ«¢a]‘Hä)À¸‹29AÓáô6»_6Jn)º9ì‡3Ã)á:LyGÙ²…¾.oa'þÕíW!z¬ÉûHö®)–Á+ô<¡›- éb¯k¹ŒF lî{,ɯr’Ç»¸ ) 1ÇzØ·ðÔoUrNœ­õ8k œ¢8í9£ÌFðŽê ƒoq?5,T$(‡½Ê媵`Yëù†5º|&buf®ƒ®a|ße!ßN'r ½Dç«üÿ×€S/« ‘qâ„ÁuϘç"œOÎÖº½c£ „D´·AãÒƒ#s+¦ lÚnÖñÿO×ÿœò¸è õ16%tEXtdate:create2012-11-08T12:56:16+01:00chç%tEXtdate:modify2012-11-08T12:48:24+01:00´i)âtEXtjpeg:colorspace2,uUŸ tEXtjpeg:sampling-factor2x2,1x1,1x1Iú¦´IEND®B`‚s9/configure000755 001751 001751 00000001165 12072760423 012736 0ustar00nmhnmh000000 000000 #!/bin/sh cat <http://' >_pro echo -n 't3x.org/s9fes/' >>_pro echo 'HACKING.html' >>_pro echo '
' >>_pro echo '
' >_epi echo '

contact

' >>_epi s9 -f prog/edoc.scm -P _pro -E _epi edoc/HACKING.edoc >HACKING.html rm -f _pro _epi #CODE s9.image: s9 s9.scm s9-real.scm ext/unix.scm ext/curses.scm config.scm $(BUILD_ENV) ./s9 -i - -n $(EXTRA_SCM) -l config.scm -d s9.image s9.1.gz: s9.1 sed -e "s,@LIBDIR@,$(LIBDIR)," s9.1.gz unix.o: ext/unix.c s9.h $(CC) $(CFLAGS) $(DEFS) -I . -o unix.o -c ext/unix.c curses.o: ext/curses.c s9.h $(CC) $(CFLAGS) $(DEFS) -I . -o curses.o -c ext/curses.c s9e-core.image: s9 s9.scm s9-real.scm ext/unix.scm ext/curses.scm \ contrib/s9e.scm $(BUILD_ENV) ./s9 -i - -n -l ext/unix.scm -l ext/curses.scm \ -l ext/parse-optionsb.scm -l contrib/s9e.scm \ -d s9e-core.image lint: gcc -g -Wall -ansi -pedantic s9.c && rm a.out test: s9 test.image $(BUILD_ENV) ./s9 -i test -f util/test.scm libtest: s9 test.image $(BUILD_ENV) sh util/libtest.sh systest: s9 test.image $(BUILD_ENV) ./s9 -i test -f util/systest.scm srtest: s9 test.image $(BUILD_ENV) ./s9 -i test -f util/srtest.scm realtest: s9 test.image $(BUILD_ENV) ./s9 -i test -f util/realtest.scm test.image: s9 s9.scm s9-real.scm $(BUILD_ENV) ./s9 -i - -n $(EXTRA_SCM) -d test.image tests: test realtest srtest libtest systest install: install-s9 install-util install-all: install-s9 install-util install-s9e install-progs # old version of install(1) may need -c #C=-c install-s9: s9 s9.scm s9.image s9.1.gz install -d -m 0755 $(BINDIR) install -d -m 0755 $(LIBDIR) install -d -m 0755 $(LIBDIR)/help install -d -m 0755 $(MANDIR) install $C -m 0755 s9 $(BINDIR) strip $(BINDIR)/s9 install $C -m 0644 s9.scm $(LIBDIR) install $C -m 0644 s9.image $(LIBDIR) install $C -m 0644 lib/* $(LIBDIR) install $C -m 0644 ext/*.scm $(LIBDIR) install $C -m 0644 contrib/* $(LIBDIR) install $C -m 0644 s9.1.gz $(MANDIR) install $C -m 0644 help/* $(LIBDIR)/help install $C -m 0755 util/make-help-links $(LIBDIR) (cd $(LIBDIR) && ./make-help-links && rm make-help-links) install-util: sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/s9help sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/s9resolve sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/scm2html sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/scmpp -chmod +x $(BINDIR)/s9help \ $(BINDIR)/s9resolve \ $(BINDIR)/scm2html \ $(BINDIR)/scmpp install-s9e: s9e-core.image ln -fs $(BINDIR)/s9 $(BINDIR)/s9e-core install $C -m 0644 s9e-core.image $(LIBDIR) sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/s9e -chmod +x $(BINDIR)/s9e install-progs: sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/advgen sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/c2html sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/cols sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/dupes sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/edoc sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/htmlify sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/s9hts sed -e "s|^#! /usr/local|#! $(PREFIX)|" \ $(BINDIR)/soccat -chmod +x $(BINDIR)/advgen \ $(BINDIR)/c2html \ $(BINDIR)/cols \ $(BINDIR)/dupes \ $(BINDIR)/edoc \ $(BINDIR)/htmlify \ $(BINDIR)/s9hts \ $(BINDIR)/soccat deinstall: deinstall-s9 deinstall-util deinstall-all: deinstall-s9 deinstall-util deinstall-s9e deinstall-progs deinstall-s9: rm -f $(LIBDIR)/help/* && rmdir $(LIBDIR)/help rm -f $(LIBDIR)/* && rmdir $(LIBDIR) rm -f $(BINDIR)/s9 -rmdir $(BINDIR) -rmdir $(MANDIR) deinstall-util: rm -f $(BINDIR)/s9help \ $(BINDIR)/s9resolve \ $(BINDIR)/scm2html \ $(BINDIR)/scmpp deinstall-progs: rm -f $(BINDIR)/advgen \ $(BINDIR)/c2html \ $(BINDIR)/cols \ $(BINDIR)/dupes \ $(BINDIR)/edoc \ $(BINDIR)/htmlify \ $(BINDIR)/s9hts \ $(BINDIR)/soccat deinstall-s9e: rm -f $(BINDIR)/s9e-core \ $(LIBDIR)/s9e-core.image tabs: @find . -name \*.scm -exec grep -l " " {} \; cd: ./s9 -f util/check-descr.scm clean: rm -f s9 s9.image s9e-core.image test.image s9.1.gz *.o *.core \ CATEGORIES.html HACKING.html core s9fes.tgz __testfile__ new-version: vi edoc/s9.c.edoc CHANGES make s9.c update-library: vi util/make-docs util/make-docs vi util/make-help-links \ util/descriptions \ util/categories.html clear @echo "Now copy the new help pages from help-new to help" @echo "and run util/make-help-links." s9.1.txt: s9.1 cc -o rpp util/rpp.c nroff s9.1 | ./rpp -a >s9.1.txt rm -f rpp docs: lib ext contrib util/make-docs webdump: util/make-html advdump: prog/advgen.scm prog/adventure.adv prog/adventure.intro sed -e 's/@dir/quest/' -e 's/@file/index/g' pagehead prog/advgen.scm -rv \ -P terminal:session \ -p pagehead \ -e util/pagetail \ -i prog/adventure.intro \ -t "The Quest for S9fES" \ -y s9.css \ prog/adventure.adv rm -f pagehead cp MASCOT.png advdump sed -e 's/^A:link/A/' -e '/^A:visited/,+3d' \ advdump/s9.css csums: txsum -u <_checksums >_checksums.new mv _checksums.new _checksums mksums: clean find . -type f | grep -v _checksums | txsum -m >_checksums stripped-arc: clean s9.1.txt mv Makefile Makefile.ORIG sed -e '/#EDOC/,/#CODE/d' Makefile cd .. && tar -cf - --exclude edoc --exclude freebsd-port s9 | \ gzip -9 > s9fes.tgz && mv s9fes.tgz s9 mv -f Makefile.ORIG Makefile ls -l s9fes.tgz | awk '{print int($$5/1024+.5)}' arc: clean s9.1.txt cd .. && tar cf - s9 | gzip -9 > s9fes.tgz && mv s9fes.tgz s9 ls -l s9fes.tgz | awk '{print int($$5/1024+.5)}' s9/help/help000644 001751 001751 00000002135 12245077675 012644 0ustar00nmhnmh000000 000000 S9 LIB (help) ==> unspecific (help symbol | string) ==> unspecific (apropos) ==> list (apropos symbol | string) ==> list (load-from-library "help.scm") Display the synopsis of the given procedure or keyword. When SYMBOL is described in R4RS, produce its R4RS entry, otherwise display a S9FES-specific summary. When no argument is passed to HELP, it explains itself. APROPOS returns a list of all procedure names for which help pages exist. When an argument is passed to APROPOS, its output is limited to topics whose name contains the argument. The *LINES-PER-PAGE* variable controls the number of lines to be printed by HELP before prompting. (help 'symbol?) ==> unspecific Output: R4RS 6.4 (symbol? object) ==> boolean Returns #T if OBJECT is a symbol, otherwise returns #F. (symbol? 'foo) ==> #t (symbol? (car '(a b))) ==> #t (symbol? "bar") ==> #f (symbol? 'nil) ==> #t (symbol? '()) ==> #f (symbol? #f) ==> #f s9/help/not000644 001751 001751 00000000414 11203550420 012463 0ustar00nmhnmh000000 000000 R4RS 6.1 (not object) ==> boolean NOT returns #T if OBJECT is false, and returns #F otherwise. (not #t) ==> #f (not 3) ==> #f (not (list 3)) ==> #f (not #f) ==> #t (not '()) ==> #f (not (list)) ==> #f (not 'nil) ==> #f s9/help/eqvp000644 001751 001751 00000011506 12033046611 012646 0ustar00nmhnmh000000 000000 R4RS 6.2 (eqv? object1 object2) ==> boolean The EQV? procedure defines a useful equivalence relation on objects. Briefly, it returns #T if OBJECT1 and OBJECT2 should normally be regarded as the same object. This relation is left slightly open to interpretation, but the following partial specification of EQV? holds for all implementations of Scheme. The EQV? procedure returns #T if: - OBJECT1 and OBJECT2 are both #T or both #F. - OBJECT1 and OBJECT2 are both symbols and (string=? (symbol->string OBJECT1) (symbol->string OBJECT2)) ==> #t Note: This assumes that neither OBJECT1 nor OBJECT2 is an "uninterned symbol" as alluded to in section 6.4 Symbols. This report does not presume to specify the behavior of EQV? on implementation-dependent extensions. - OBJECT1 and OBJECT2 are both numbers, are numerically equal (see =, section see section 6.5 Numbers), and are either both exact or both inexact. - OBJECT1 and OBJECT2 are both characters and are the same character according to the char=? procedure (section see section 6.6 Characters). - both OBJECT1 and OBJECT2 are the empty list. - OBJECT1 and OBJECT2 are pairs, vectors, or strings that denote the same locations in the store (section see section 3.5 Storage model). - OBJECT1 and OBJECT2 are procedures whose location tags are equal (section see section 4.1.4 lambda expressions). The EQV? procedure returns #F if: - one of OBJECT1 and OBJECT2 is an exact number but the other is an inexact number. - OBJECT1 and OBJECT2 are of different types (section see section 3.4 Disjointness of types). - one of OBJECT1 and OBJECT2 is #T but the other is #F. - OBJECT1 and OBJECT2 are symbols but (string=? (symbol->string OBJECT1) (symbol->string OBJECT2)) ==> #f - OBJECT1 and OBJECT2 are numbers for which the = procedure returns #F. - OBJECT1 and OBJECT2 are characters for which the char=? procedure returns #F. - one of OBJECT1 and OBJECT2 is the empty list but the other is not. - OBJECT1 and OBJECT2 are pairs, vectors, or strings that denote distinct locations. - OBJECT1 and OBJECT2 are procedures that would behave differently (return a different value or have different side effects) for some arguments. (eqv? 'a 'a) ==> #t (eqv? 'a 'b) ==> #f (eqv? 2 2) ==> #t (eqv? '() '()) ==> #t (eqv? 100000000 100000000) ==> #t (eqv? (cons 1 2) (cons 1 2)) ==> #f (eqv? (lambda () 1) (lambda () 2)) ==> #f (eqv? #f 'nil) ==> #f (let ((p (lambda (x) x))) (eqv? p p)) ==> #t The following examples illustrate cases in which the above rules do not fully specify the behavior of EQV?. All that can be said about such cases is that the value returned by EQV? must be a boolean. (eqv? "" "") ==> unspecified (eqv? '#() '#()) ==> unspecified (eqv? (lambda (x) x) (lambda (x) x)) ==> unspecified (eqv? (lambda (x) x) (lambda (y) y)) ==> unspecified The next set of examples shows the use of EQV? with procedures that have local state. Gen-counter must return a distinct procedure every time, since each procedure has its own internal counter. Gen-loser, however, returns equivalent procedures each time, since the local state does not affect the value or side effects of the procedures. (define (gen-counter) (let ((n 0)) (lambda () (set! n (+ n 1)) n))) (let ((g (gen-counter))) (eqv? g g)) ==> #t (eqv? (gen-counter) (gen-counter)) ==> #f (define (gen-loser) (let ((n 0)) (lambda () (set! n (+ n 1)) 27))) (let ((g (gen-loser))) (eqv? g g)) ==> #t (eqv? (gen-loser) (gen-loser)) ==> unspecified (letrec ((f (lambda () (if (eqv? f g) 'both 'f))) (g (lambda () (if (eqv? f g) 'both 'g))) (eqv? f g))) ==> unspecified (letrec ((f (lambda () (if (eqv? f g) 'f 'both))) (g (lambda () (if (eqv? f g) 'g 'both))) (eqv? f g))) ==> #f Since it is an error to modify constant objects (those returned by literal expressions), implementations are permitted, though not required, to share structure between constants where appropriate. Thus the value of EQV? on constants is sometimes implementation-dependent. (eqv? '(a) '(a)) ==> unspecified (eqv? "a" "a") ==> unspecified (eqv? '(b) (cdr '(a b))) ==> unspecified (let ((x '(a))) (eqv? x x)) ==> #t Rationale: The above definition of EQV? allows implementations latitude in their treatment of procedures and literals: implementations are free either to detect or to fail to detect that two procedures or two literals are equivalent to each other, and can decide whether or not to merge representations of equivalent objects by using the same pointer or bit pattern to represent both. s9/help/delete-file000644 001751 001751 00000000241 11203544622 014047 0ustar00nmhnmh000000 000000 S9fES (delete-file string) ==> unspecific Delete the file specifed in the STRING argument. If the file does not exist or cannot be deleted, report an error. s9/help/booleanp000644 001751 001751 00000000277 11203541663 013502 0ustar00nmhnmh000000 000000 R4RS 6.1 (boolean? object) ==> boolean BOOLEAN? returns #T if OBJECT is either #T or #F and returns #F otherwise. (boolean? #f) ==> #t (boolean? 0) ==> #f (boolean? '()) ==> #f s9/help/eqp000644 001751 001751 00000003153 11203545167 012467 0ustar00nmhnmh000000 000000 R4RS 6.2 (eq? object1 object2) ==> boolean EQ? is similar to EQV? except that in some cases it is capable of discerning distinctions finer than those detectable by EQV?. EQ? and EQV? are guaranteed to have the same behavior on symbols, booleans, the empty list, pairs, and non-empty strings and vectors. EQ?'s behavior on numbers and characters is implementation-dependent, but it will always return either true or false, and will return true only when EQV? would also return true. EQ? may also behave differently from EQV? on empty vectors and empty strings. (eq? 'a 'a) ==> #t (eq? '(a) '(a)) ==> unspecified (eq? (list 'a) (list 'a)) ==> #f (eq? "a" "a") ==> unspecified (eq? "" "") ==> unspecified (eq? '() '()) ==> #t (eq? 2 2) ==> unspecified (eq? #\A #\A) ==> unspecified (eq? car car) ==> #t (let ((n (+ 2 3))) (eq? n n)) ==> unspecified (let ((x '(a))) (eq? x x)) ==> #t (let ((x '#())) (eq? x x)) ==> #t (let ((p (lambda (x) x))) (eq? p p)) ==> #t Rationale: It will usually be possible to implement EQ? much more efficiently than EQV?, for example, as a simple pointer comparison instead of as some more complicated operation. One reason is that it may not be possible to compute EQV? of two numbers in constant time, whereas EQ? implemented as pointer comparison will always finish in constant time. EQ? may be used like EQV? in applications using procedures to implement objects with state since it obeys the same constraints as EQV?. s9/help/equalp000644 001751 001751 00000001242 11203545172 013162 0ustar00nmhnmh000000 000000 R4RS 6.2 (equal? object1 object2) ==> boolean EQUAL? recursively compares the contents of pairs, vectors, and strings, applying eqv? on other objects such as numbers and symbols. A rule of thumb is that objects are generally EQUAL? if they print the same. EQUAL? may fail to terminate if its arguments are circular data structures. (equal? 'a 'a) ==> #t (equal? '(a) '(a)) ==> #t (equal? '(a (b) c) '(a (b) c)) ==> #t (equal? "abc" "abc") ==> #t (equal? 2 2) ==> #t (equal? (make-vector 5 'a) (make-vector 5 'a)) ==> #t (equal? (lambda (x) x) (lambda (y) y)) ==> unspecified s9/help/pairp000644 001751 001751 00000000321 11203550776 013011 0ustar00nmhnmh000000 000000 R4RS 6.3 (pair? object) ==> boolean PAIR? returns #T if OBJECT is a pair, and otherwise returns #F. (pair? '(a . b)) ==> #t (pair? '(a b c)) ==> #t (pair? '()) ==> #f (pair? '#(a b)) ==> #f s9/help/cons000644 001751 001751 00000000613 11203543435 012636 0ustar00nmhnmh000000 000000 R4RS 6.3 (cons object1 object2) ==> pair Returns a newly allocated pair whose car is OBJECT1 and whose cdr is OBJECT2. The pair is guaranteed to be different (in the sense of EQV?) from every existing object. (cons 'a '()) ==> (a) (cons '(a) '(b c d)) ==> ((a) b c d) (cons "a" '(b c)) ==> ("a" b c) (cons 'a 3) ==> (a . 3) (cons '(a b) 'c) ==> ((a b) . c) s9/help/car000644 001751 001751 00000000401 11203542061 012426 0ustar00nmhnmh000000 000000 R4RS 6.3 (car pair) ==> object Returns the contents of the car field of PAIR. Note that it is an error to take the car of the empty list. (car '(a b c)) ==> a (car '((a) b c d)) ==> (a) (car '(1 . 2)) ==> 1 (car '()) ==> error s9/help/cdr000644 001751 001751 00000000352 11203542623 012442 0ustar00nmhnmh000000 000000 R4RS 6.3 (cdr pair) ==> object Returns the contents of the cdr field of PAIR. Note that it is an error to take the cdr of the empty list. (cdr '((a) b c d)) ==> (b c d) (cdr '(1 . 2)) ==> 2 (cdr '()) ==> error s9/help/set-carb000644 001751 001751 00000000423 11203551407 013371 0ustar00nmhnmh000000 000000 R4RS 6.3 (set-car! pair object) ==> unspecific Stores OBJECT in the car field of PAIR. The value returned by SET-CAR! is unspecified. (define (f) (list 'not-a-constant-list)) (define (g) '(constant-list)) (set-car! (f) 3) ==> unspecified (set-car! (g) 3) ==> error s9/help/set-cdrb000644 001751 001751 00000000423 11203551437 013377 0ustar00nmhnmh000000 000000 R4RS 6.3 (set-cdr! pair object) ==> unspecific Stores OBJECT in the cdr field of PAIR. The value returned by SET-CDR! is unspecified. (define (f) (list 'not-a-constant-list)) (define (g) '(constant-list)) (set-cdr! (f) 3) ==> unspecified (set-cdr! (g) 3) ==> error s9/help/caar000644 001751 001751 00000000625 11203541716 012605 0ustar00nmhnmh000000 000000 R4RS 6.3 (caar pair) ==> object (cadr pair) ==> object ... (cdddar pair) ==> object (cddddr pair) ==> object These procedures are compositions of car and cdr, where for example caddr could be defined by (define (caddr x) (car (cdr (cdr x)))). Arbitrary compositions, up to four deep, are provided. There are twenty-eight of these procedures in all. s9/help/cadr000755 001751 001751 00000000000 12245077725 013442 2caarustar00nmhnmh000000 000000 s9/help/cdar000755 001751 001751 00000000000 12245077725 013442 2caarustar00nmhnmh000000 000000 s9/help/cddr000755 001751 001751 00000000000 12245077725 013445 2caarustar00nmhnmh000000 000000 s9/help/caadr000755 001751 001751 00000000000 12245077725 013603 2caarustar00nmhnmh000000 000000 s9/help/cadar000755 001751 001751 00000000000 12245077725 013603 2caarustar00nmhnmh000000 000000 s9/help/caddr000755 001751 001751 00000000000 12245077725 013606 2caarustar00nmhnmh000000 000000 s9/help/cdaar000755 001751 001751 00000000000 12245077725 013603 2caarustar00nmhnmh000000 000000 s9/help/cdadr000755 001751 001751 00000000000 12245077725 013606 2caarustar00nmhnmh000000 000000 s9/help/cddar000755 001751 001751 00000000000 12245077725 013606 2caarustar00nmhnmh000000 000000 s9/help/cdddr000755 001751 001751 00000000000 12245077725 013611 2caarustar00nmhnmh000000 000000 s9/help/cdddar000755 001751 001751 00000000000 12245077725 013752 2caarustar00nmhnmh000000 000000 s9/help/caaadr000755 001751 001751 00000000000 12245077725 013744 2caarustar00nmhnmh000000 000000 s9/help/caadar000755 001751 001751 00000000000 12245077725 013744 2caarustar00nmhnmh000000 000000 s9/help/caaddr000755 001751 001751 00000000000 12245077725 013747 2caarustar00nmhnmh000000 000000 s9/help/cadaar000755 001751 001751 00000000000 12245077725 013744 2caarustar00nmhnmh000000 000000 s9/help/char-numericp000755 001751 001751 00000000000 12245077725 017547 2char-alphabeticpustar00nmhnmh000000 000000 s9/help/cadadr000755 001751 001751 00000000000 12245077725 013747 2caarustar00nmhnmh000000 000000 s9/help/caddar000755 001751 001751 00000000000 12245077725 013747 2caarustar00nmhnmh000000 000000 s9/help/cadddr000755 001751 001751 00000000000 12245077725 013752 2caarustar00nmhnmh000000 000000 s9/help/cdaaar000755 001751 001751 00000000000 12245077725 013744 2caarustar00nmhnmh000000 000000 s9/help/cdaadr000755 001751 001751 00000000000 12245077725 013747 2caarustar00nmhnmh000000 000000 s9/help/cdadar000755 001751 001751 00000000000 12245077725 013747 2caarustar00nmhnmh000000 000000 s9/help/cdaddr000755 001751 001751 00000000000 12245077725 013752 2caarustar00nmhnmh000000 000000 s9/help/cddaar000755 001751 001751 00000000000 12245077725 013747 2caarustar00nmhnmh000000 000000 s9/help/cddadr000755 001751 001751 00000000000 12245077725 013752 2caarustar00nmhnmh000000 000000 s9/help/cddddr000755 001751 001751 00000000000 12245077725 013755 2caarustar00nmhnmh000000 000000 s9/help/nullp000644 001751 001751 00000000146 11203550435 013025 0ustar00nmhnmh000000 000000 R4RS 6.3 (null? object) ==> boolean Returns #T if OBJECT is the empty list, otherwise returns #F. s9/help/listp000644 001751 001751 00000000517 11203547276 013041 0ustar00nmhnmh000000 000000 R4RS 6.3 (list? object) ==> boolean Returns #T if OBJECT is a list, otherwise returns #F. By definition, all lists have finite length and are terminated by the empty list. (list? '(a b c)) ==> #t (list? '()) ==> #t (list? '(a . b)) ==> #f (let ((x (list 'a))) (set-cdr! x x) (list? x)) ==> #f s9/help/list000644 001751 001751 00000000233 11203547075 012651 0ustar00nmhnmh000000 000000 R4RS 6.3 (list object ...) ==> list Returns a newly allocated list of its arguments. (list 'a (+ 3 4) 'c) ==> (a 7 c) (list) ==> () s9/help/append000644 001751 001751 00000001155 11203474303 013142 0ustar00nmhnmh000000 000000 R4RS 6.3 (append list ...) ==> list (append list ... object) ==> object Returns a list consisting of the elements of the first list followed by the elements of the other lists. (append '(x) '(y)) ==> (x y) (append '(a) '(b c d)) ==> (a b c d) (append '(a (b)) '((c))) ==> (a (b) (c)) The resulting list is always newly allocated, except that it shares structure with the last list argument. The last argument may actually be any object; an improper list results if the last argument is not a proper list. (append '(a b) '(c . d)) ==> (a b c . d) (append '() 'a) ==> a s9/help/length000644 001751 001751 00000000252 11203546674 013164 0ustar00nmhnmh000000 000000 R4RS 6.3 (length list) ==> integer Returns the length of list. (length '(a b c)) ==> 3 (length '(a (b) (c d e))) ==> 3 (length '()) ==> 0 s9/help/reverse000644 001751 001751 00000000340 11203551370 013341 0ustar00nmhnmh000000 000000 R4RS 6.3 (reverse list) ==> list Returns a newly allocated list consisting of the elements of LIST in reverse order. (reverse '(a b c)) ==> (c b a) (reverse '(a (b c) d (e (f)))) ==> ((e (f)) d (b c) a) s9/help/list-tail000644 001751 001751 00000000357 11431711100 013570 0ustar00nmhnmh000000 000000 R4RS 6.3 (list-tail list integer) ==> list Returns the sublist of LIST obtained by omitting the first INTEGER elements. LIST-TAIL could be defined by (define (list-tail x k) (if (zero? k) x (list-tail (cdr x) (- k 1)))) s9/help/list-ref000644 001751 001751 00000000261 11431711075 013420 0ustar00nmhnmh000000 000000 R4RS 6.3 (list-ref list integer) ==> obj Returns the INTEGER'th element of list. (This is the same as the car of (list-tail list INTEGER).) (list-ref '(a b c d) 2) ==> c s9/help/memq000644 001751 001751 00000001456 11203550006 012631 0ustar00nmhnmh000000 000000 R4RS 6.3 (memq object list) ==> list | #f (memv object list) ==> list | #f (member object list) ==> list | #f These procedures return the first sublist of LIST whose car is OBJECT, where the sublists of LIST are the non-empty lists returned by (list-tail list k) for K less than the length of LIST. If OBJECT does not occur in LIST, then #F (not the empty list) is returned. MEMQ uses EQ? to compare OBJECT with the elements of LIST, while MEMV uses EQV? and MEMBER uses EQUAL?. (memq 'a '(a b c)) ==> (a b c) (memq 'b '(a b c)) ==> (b c) (memq 'a '(b c d)) ==> #f (memq (list 'a) '(b (a) c)) ==> #f (member (list 'a) '(b (a) c)) ==> ((a) c) (memq 101 '(100 101 102)) ==> unspecified (memv 101 '(100 101 102)) ==> (101 102) s9/help/memv000755 001751 001751 00000000000 12245077725 013526 2memqustar00nmhnmh000000 000000 s9/help/member000755 001751 001751 00000000000 12245077725 014031 2memqustar00nmhnmh000000 000000 s9/help/assq000644 001751 001751 00000002106 11203554717 012647 0ustar00nmhnmh000000 000000 R4RS 6.3 (assq object alist) ==> pair | #f (assv object alist) ==> pair | #f (assoc object alist) ==> pair | #f ALIST (for "association list") must be a list of pairs. These procedures find the first pair in ALIST whose car field is OBJECT, and returns that pair. If no pair in ALIST has OBJECT as its car, then #F (not the empty list) is returned. ASSQ uses EQ? to compare OBJECT with the car fields of the pairs in ALIST, while ASSV uses EQV? and ASSOC uses EQUAL?. (define e '((a 1) (b 2) (c 3))) (assq 'a e) ==> (a 1) (assq 'b e) ==> (b 2) (assq 'd e) ==> #f (assq (list 'a) '(((a)) ((b)) ((c)))) ==> #f (assoc (list 'a) '(((a)) ((b)) ((c)))) ==> ((a)) (assq 5 '((2 3) (5 7) (11 13))) ==> unspecified (assv 5 '((2 3) (5 7) (11 13))) ==> (5 7) Rationale: Although they are ordinarily used as predicates, MEMQ, MEMV, MEMBER, ASSQ, ASSV, and ASSOC do not have question marks in their names because they return useful values rather than just #T or #F. s9/help/assv000755 001751 001751 00000000000 12245077724 013545 2assqustar00nmhnmh000000 000000 s9/help/symbolp000644 001751 001751 00000000443 11203553015 013355 0ustar00nmhnmh000000 000000 R4RS 6.4 (symbol? object) ==> boolean Returns #T if OBJECT is a symbol, otherwise returns #F. (symbol? 'foo) ==> #t (symbol? (car '(a b))) ==> #t (symbol? "bar") ==> #f (symbol? 'nil) ==> #t (symbol? '()) ==> #f (symbol? #f) ==> #f s9/help/symbol-to-string000644 001751 001751 00000001751 11203552737 015136 0ustar00nmhnmh000000 000000 R4RS 6.4 (symbol->string symbol) ==> string Returns the name of SYMBOL as a string. If the symbol was part of an object returned as the value of a literal expression (section see section 4.1.2 Literal expressions) or by a call to the READ procedure, and its name contains alphabetic characters, then the string returned will contain characters in the implementation's preferred standard case--some implementations will prefer upper case, others lower case. If the symbol was returned by STRING->SYMBOL, the case of characters in the string returned will be the same as the case in the string that was passed to STRING->SYMBOL. It is an error to apply mutation procedures like STRING-SET! to strings returned by this procedure. The following examples assume that the implementation's standard case is lower case: (symbol->string 'flying-fish) ==> "flying-fish" (symbol->string 'Martin) ==> "martin" (symbol->string (string->symbol "Malvina")) ==> "Malvina" s9/help/string-to-symbol000644 001751 001751 00000001602 11203552605 015123 0ustar00nmhnmh000000 000000 R4RS 6.4 (string->symbol string) ==> symbol Returns the symbol whose name is STRING. This procedure can create symbols with names containing special characters or letters in the non-standard case, but it is usually a bad idea to create such symbols because in some implementations of Scheme they cannot be read as themselves. See SYMBOL->STRING. The following examples assume that the implementation's standard case is lower case: (eq? 'mISSISSIppi 'mississippi) ==> #t (string->symbol "mISSISSIppi") ==> the symbol with name "mISSISSIppi" (eq? 'bitBlt (string->symbol "bitBlt")) ==> #f (eq? 'JollyWog (string->symbol (symbol->string 'JollyWog))) ==> #t (string=? (symbol->string (string->symbol "K. Harper, M.D.")) "K. Harper, M.D." ==> #t s9/help/numberp000644 001751 001751 00000001440 11430005040 013326 0ustar00nmhnmh000000 000000 R4RS 6.5.5 (integer? object) ==> boolean (number? object) ==> boolean (real? object) ==> boolean These numerical type predicates can be applied to any kind of argument, including non-numbers. They return #t if the object is of the named type, and otherwise they return #f. In general, if a type predicate is true of a number then all higher type predicates are also true of that number. Consequently, if a type predicate is false of a number, then all lower type predicates are also false of that number. (real? 3) ==> #t (real? -2.5) ==> #t (real? #e1e10) ==> #t (integer? 3) ==> #t (integer? 3.0) ==> #t Note: The behavior of these type predicates on inexact numbers is unreliable, since any inaccuracy may affect the result. s9/help/eq000644 001751 001751 00000001512 12033046527 012302 0ustar00nmhnmh000000 000000 R4RS 6.5.5 (= number1 number2 ...) ==> boolean (< number1 number2 ...) ==> boolean (> number1 number2 ...) ==> boolean (<= number1 number2 ...) ==> boolean (>= number1 number2 ...) ==> boolean These procedures return #T if their arguments are (respectively): equal, monotonically increasing, monotonically decreasing, monotonically nondecreasing, or monotonically non-increasing. These predicates are required to be transitive. Note: The traditional implementations of these predicates in Lisp-like languages are not transitive. Note: While it is not an error to compare inexact numbers using these predicates, the results may be unreliable because a small inaccuracy may affect the result; this is especially true of = and ZERO?. When in doubt, consult a numerical analyst. s9/help/lt000755 001751 001751 00000000000 12245077725 012647 2equstar00nmhnmh000000 000000 s9/help/bitwise-and-c1000755 001751 001751 00000000000 12245077725 016540 2bitwise-andustar00nmhnmh000000 000000 s9/help/gt000755 001751 001751 00000000000 12245077725 012642 2equstar00nmhnmh000000 000000 s9/help/le000755 001751 001751 00000000000 12245077725 012630 2equstar00nmhnmh000000 000000 s9/help/ge000755 001751 001751 00000000000 12245077725 012623 2equstar00nmhnmh000000 000000 s9/help/zerop000644 001751 001751 00000000541 11430004470 013024 0ustar00nmhnmh000000 000000 R4RS 6.5.5 (zero? number) ==> boolean (positive? number) ==> boolean (negative? number) ==> boolean (odd? integer) ==> boolean (even? integer) ==> boolean These numerical predicates test a number for a particular property, returning #T or #F. See also: note 2 in description of =. s9/help/positivep000755 001751 001751 00000000000 12245077725 015004 2zeropustar00nmhnmh000000 000000 s9/help/negativep000755 001751 001751 00000000000 12245077725 014744 2zeropustar00nmhnmh000000 000000 s9/help/oddp000755 001751 001751 00000000000 12245077725 013710 2zeropustar00nmhnmh000000 000000 s9/help/evenp000755 001751 001751 00000000000 12245077725 014077 2zeropustar00nmhnmh000000 000000 s9/help/max000644 001751 001751 00000000444 11431711160 012456 0ustar00nmhnmh000000 000000 R4RS 6.5.5 (max number ...) ==> number (min number ...) ==> number These procedures return the maximum or minimum of their arguments. (max 3 4) ==> 4 ; exact (min 3 4.1) ==> 3.0 ; inexact Note: If any argument is inexact, then the result will also be inexact. s9/help/min000755 001751 001751 00000000000 12245077725 013173 2maxustar00nmhnmh000000 000000 s9/help/plus000644 001751 001751 00000000465 11212246153 012661 0ustar00nmhnmh000000 000000 R4RS 6.5.5 (+ number1 ...) ==> number (+) ==> number (* number1 ...) ==> number (*) ==> number These procedures return the sum or product of their arguments. (+ 3 4) ==> 7 (+ 3) ==> 3 (+) ==> 0 (* 4) ==> 4 (*) ==> 1 s9/help/letstar000644 001751 001751 00000001124 11775333272 013362 0ustar00nmhnmh000000 000000 R4RS 4.2.2 (let* ) ==> object Syntax: should have the form (( ) ...), and should be a sequence of one or more expressions. Semantics: LET* is similar to LET, but the bindings are performed sequentially from left to right, and the region of a binding indicated by `( )' is that part of the LET* expression to the right of the binding. Thus the second binding is done in an environment in which the first binding is visible, and so on. (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))) ==> 70 s9/help/minus000644 001751 001751 00000000624 11430006274 013026 0ustar00nmhnmh000000 000000 R4RS 6.5.5 (- number ...) ==> number (/ number ...) ==> number With two or more arguments, these procedures return the difference or quotient of their arguments, associating to the left. With one argument, however, they return the additive or multiplicative inverse of their argument. (- 3 4) ==> -1 (- 3 4 5) ==> -6 (- 3) ==> -3 (/ 3 4 5) ==> 0.15 (/ 4) ==> 0.25 s9/help/abs000644 001751 001751 00000000144 11212244666 012444 0ustar00nmhnmh000000 000000 R4RS 6.5.5 (abs number) ==> number ABS returns the magnitude of its argument. (abs -7) ==> 7 s9/help/quotient000644 001751 001751 00000001767 11430006377 013560 0ustar00nmhnmh000000 000000 R4RS 6.5.5 (quotient integer1 integer2) ==> integer (remainder integer1 integer2) ==> integer (modulo integer1 integer2) ==> integer These procedures implement number-theoretic (integer) division: For positive integers n1 and n2, if n3 and n4 are integers such that n1=n2*n3+n4 and 0<=n4 n3 (remainder n1 n2) ==> n4 (modulo n1 n2) ==> n4 For integers n1 and n2 with n2 not equal to 0, (= n1 (+ (* n2 (quotient n1 n2)) (remainder n1 n2))) ==> #t. The value returned by QUOTIENT always has the sign of the product of its arguments. REMAINDER and MODULO differ on negative arguments--the remainder is either zero or has the sign of the dividend, while the modulo always has the sign of the divisor: (modulo 13 4) ==> 1 (remainder 13 4) ==> 1 (modulo -13 4) ==> 3 (remainder -13 4) ==> -1 (modulo 13 -4) ==> -3 (remainder 13 -4) ==> 1 (modulo -13 -4) ==> -1 (remainder -13 -4) ==> -1 s9/help/remainder000755 001751 001751 00000000000 12245077725 015441 2quotientustar00nmhnmh000000 000000 s9/help/modulo000755 001751 001751 00000000000 12245077725 014772 2quotientustar00nmhnmh000000 000000 s9/help/gcd000644 001751 001751 00000000464 11775333033 012442 0ustar00nmhnmh000000 000000 R4RS 6.5.5 (gcd integer ...) ==> integer (lcm integer ...) ==> integer These procedures return the greatest common divisor or least common multiple of their arguments. The result is always non-negative. (gcd 32 -36) ==> 4 (gcd) ==> 0 (lcm 32 -36) ==> 288 (lcm) ==> 1 s9/help/lcm000755 001751 001751 00000000000 12245077725 013133 2gcdustar00nmhnmh000000 000000 s9/help/expt000644 001751 001751 00000000207 11430005155 012645 0ustar00nmhnmh000000 000000 R4RS 6.5.5 (expt number1 number2) ==> number Returns NUMBER1 raised to the power NUMBER2. (Expt 0 0) is defined to be equal to 1. s9/help/number-to-string000644 001751 001751 00000001760 12033047072 015112 0ustar00nmhnmh000000 000000 R4RS 6.5.6 (number->string number) ==> string (number->string number integer) ==> string INTEGER must be a radix of either 2, 8, 10, or 16. If omitted, it defaults to 10. The procedure NUMBER->STRING takes a number and a radix and returns as a string an external representation of the given number in the given radix such that (let ((number number) (radix radix)) (eqv? number (string->number (number->string number radix) radix))) is true. It is an error if no possible result makes this expression true. If NUMBER is inexact, the radix is 10, and the above expression can be satisfied by a result that contains a decimal point, then the result contains a decimal point and is expressed using the minimum number of digits (exclusive of exponent and trailing zeros) needed to make the above expression true; otherwise the format of the result is unspecified. The result returned by NUMBER->STRING never contains an explicit radix prefix. s9/help/string-to-number000644 001751 001751 00000001614 11431711270 015107 0ustar00nmhnmh000000 000000 R4RS 6.5.6 (string->number string) ==> integer (string->number string integer) ==> integer Returns a number of the maximally precise representation expressed by the given STRING. INTEGER must be an exact integer, either 2, 8, 10, or 16. If supplied, INTEGER is a default radix that may be overridden by an explicit radix prefix in string (e.g. "#o177"). If INTEGER is not supplied, then the default radix is 10. If STRING is not a syntactically valid notation for a number, then STRING->NUMBER returns #F. (string->number "100") ==> 100 (string->number "100" 16) ==> 256 (string->number "1e2") ==> 100.0 (string->number "1.23") ==> 1.23 (string->number "#i10") ==> 10.0 The S9fES implementation supports base prefixes. It also supports decimal points, exponent markers, unspecific digits (#), and exact/inexact prefixes, if real number support is compiled in. s9/help/charp000644 001751 001751 00000000143 11203543240 012761 0ustar00nmhnmh000000 000000 R4RS 6.6 (char? object) ==> boolean Returns #T if OBJECT is a character, otherwise returns #F. s9/help/charltp000755 001751 001751 00000000000 12245077725 014703 2chareqpustar00nmhnmh000000 000000 s9/help/chareqp000644 001751 001751 00000001653 11203543212 013315 0ustar00nmhnmh000000 000000 R4RS 6.6 (char=? char1 char2) ==> boolean (char boolean (char>? char1 char2) ==> boolean (char<=? char1 char2) ==> boolean (char>=? char1 char2) ==> boolean These procedures impose a total ordering on the set of characters. It is guaranteed that under this ordering: - The upper case characters are in order. For example, (char #t. - The lower case characters are in order. For example, (char #t. - The digits are in order. For example, (char #t. - Either all the digits precede all the upper case letters, or vice versa. - Either all the digits precede all the lower case letters, or vice versa. Some implementations may generalize these procedures to take more than two arguments, as with the corresponding numerical predicates. The S9fES versions of these procedures do accept more than two arguments. s9/help/chargtp000755 001751 001751 00000000000 12245077725 014676 2chareqpustar00nmhnmh000000 000000 s9/help/charlep000755 001751 001751 00000000000 12245077725 014664 2chareqpustar00nmhnmh000000 000000 s9/help/chargep000755 001751 001751 00000000000 12245077725 014657 2chareqpustar00nmhnmh000000 000000 s9/help/char-cieqp000644 001751 001751 00000001144 11203542727 013713 0ustar00nmhnmh000000 000000 R4RS 6.6 (char-ci=? char1 char2) ==> boolean (char-ci boolean (char-ci>? char1 char2) ==> boolean (char-ci<=? char1 char2) ==> boolean (char-ci>=? char1 char2) ==> boolean These procedures are similar to CHAR=? et cetera, but they treat upper case and lower case letters as the same. For example, (char-ci=? #\A #\a) ==> #t. Some implementations may generalize these procedures to take more than two arguments, as with the corresponding numerical predicates. The S9fES versions of these procedures do accept more than two arguments. s9/help/char-ciltp000755 001751 001751 00000000000 12245077725 015665 2char-cieqpustar00nmhnmh000000 000000 s9/help/stringp000644 001751 001751 00000000142 11203552773 013364 0ustar00nmhnmh000000 000000 R4RS 6.7 (string? object) ==> boolean Returns #T if OBJECT is a string, otherwise returns #F. s9/help/char-cilep000755 001751 001751 00000000000 12245077725 015646 2char-cieqpustar00nmhnmh000000 000000 s9/help/char-cigep000755 001751 001751 00000000000 12245077725 015641 2char-cieqpustar00nmhnmh000000 000000 s9/help/char-cigtp000755 001751 001751 00000000000 12245077725 015660 2char-cieqpustar00nmhnmh000000 000000 s9/help/char-alphabeticp000644 001751 001751 00000001301 11212245002 015043 0ustar00nmhnmh000000 000000 R4RS 6.6 (char-alphabetic? char) ==> boolean (char-numeric? char) ==> boolean (char-whitespace? char) ==> boolean (char-upper-case? char) ==> boolean (char-lower-case? char) ==> boolean These procedures return #T if their arguments are alphabetic, numeric, whitespace, upper case, or lower case characters, respectively, otherwise they return #F. The following remarks, which are specific to the ASCII character set, are intended only as a guide: The alphabetic characters are the 52 upper and lower case letters. The numeric characters are the ten decimal digits. The whitespace characters are space, tab, line feed, form feed, and carriage return. s9/help/char-whitespacep000755 001751 001751 00000000000 12245077725 020241 2char-alphabeticpustar00nmhnmh000000 000000 s9/help/char-upper-casep000755 001751 001751 00000000000 12245077725 020151 2char-alphabeticpustar00nmhnmh000000 000000 s9/help/integer-to-char000755 001751 001751 00000000000 12245077725 017603 2char-to-integerustar00nmhnmh000000 000000 s9/help/char-lower-casep000755 001751 001751 00000000000 12245077725 020146 2char-alphabeticpustar00nmhnmh000000 000000 s9/help/char-to-integer000644 001751 001751 00000001324 11431711057 014664 0ustar00nmhnmh000000 000000 R4RS 6.6 (char->integer char) ==> integer (integer->char integer) ==> char Given a character, CHAR->INTEGER returns an integer representation of the character. Given an integer that is the image of a character under CHAR->INTEGER, INTEGER->CHAR returns that character. These procedures implement injective order isomorphisms between the set of characters under the CHAR<=? ordering and some subset of the integers under the <= ordering. That is, if (char<=? a b) ==> #t and (<= x y) ==> #t and X and Y are in the domain of INTEGER->CHAR, then (<= (char->integer a) (char->integer b)) ==> #t and (char<=? (integer->char x) (integer->char y)) ==> #t. s9/help/char-downcase000755 001751 001751 00000000000 12245077725 016534 2char-upcaseustar00nmhnmh000000 000000 s9/help/char-upcase000644 001751 001751 00000000454 11203543010 014057 0ustar00nmhnmh000000 000000 R4RS 6.6 (char-upcase char) ==> char (char-downcase char) ==> char These procedures return a character CHAR2 such that (char-ci=? char char2) ==> #t. In addition, if CHAR is alphabetic, then the result of CHAR-UPCASE is upper case and the result of CHAR-DOWNCASE is lower case. s9/help/curs_addstr000755 001751 001751 00000000000 12245077725 016237 2curs_addchustar00nmhnmh000000 000000 s9/help/make-string000644 001751 001751 00000000446 11431711103 014111 0ustar00nmhnmh000000 000000 R4RS 6.7 (make-string integer) ==> string (make-string integer char) ==> string MAKE-STRING returns a newly allocated string of length INTEGER. If CHAR is given, then all elements of the string are initialized to CHAR, otherwise the contents of the string are unspecified. s9/help/string000644 001751 001751 00000000146 11203551717 013205 0ustar00nmhnmh000000 000000 R4RS 6.7 (string char ...) ==> string Returns a newly allocated string composed of the arguments. s9/help/string-length000644 001751 001751 00000000146 11203552075 014462 0ustar00nmhnmh000000 000000 R4RS 6.7 (string-length string) ==> integer Returns the number of characters in the given string. s9/help/string-ref000644 001751 001751 00000000271 11431711112 013744 0ustar00nmhnmh000000 000000 R4RS 6.7 (string-ref string integer) ==> char INTEGER must be a valid index of STRING. STRING-REF returns character at the INTEGER'th position of STRING using zero-origin indexing. s9/help/string-setb000644 001751 001751 00000000704 11431711115 014131 0ustar00nmhnmh000000 000000 R4RS 6.7 (string-set! string integer char) ==> unspecific INTEGER must be a valid index of STRING. STRING-SET! stores CHAR in the element at the INTEGER'th position of STRING and returns an unspecified value. (define (f) (make-string 3 #\*)) (define (g) "***") (string-set! (f) 0 #\?) ==> unspecified (string-set! (g) 0 #\?) ==> error (string-set! (symbol->string 'immutable) 0 #\?) ==> error s9/help/stringeqp000644 001751 001751 00000000605 11203551746 013715 0ustar00nmhnmh000000 000000 R4RS 6.7 (string=? string1 string2) ==> boolean (string-ci=? string1 string2) ==> boolean Returns #T if the two strings are the same length and contain the same characters in the same positions, otherwise returns #F. STRING-CI=? treats upper and lower case letters as though they were the same character, but STRING=? treats upper and lower case as distinct characters. s9/help/string-cieqp000755 001751 001751 00000000000 12245077725 016244 2stringeqpustar00nmhnmh000000 000000 s9/help/stringlep000755 001751 001751 00000000000 12245077725 015660 2stringltpustar00nmhnmh000000 000000 s9/help/stringltp000644 001751 001751 00000002056 11203552027 013722 0ustar00nmhnmh000000 000000 R4RS 6.7 (string boolean (string>? string1 string2) ==> boolean (string<=? string1 string2) ==> boolean (string>=? string1 string2) ==> boolean (string-ci boolean (string-ci>? string1 string2) ==> boolean (string-ci<=? string1 string2) ==> boolean (string-ci>=? string1 string2) ==> boolean These procedures are the lexicographic extensions to strings of the corresponding orderings on characters. For example, STRING string STRING must be a string, and INTEGER-0 and INTEGER-N must satisfy 0 <= INTEGER-0 <= INTEGER-N <= (string-length string). SUBSTRING returns a newly allocated string formed from the characters of STRING beginning with index INTEGER-0 (inclusive) and ending with index INTEGER-N (exclusive). s9/help/string-append000644 001751 001751 00000000222 11203551730 014440 0ustar00nmhnmh000000 000000 R4RS 6.7 (string-append string ...) ==> string Returns a newly allocated string whose characters form the concatenation of the given strings. s9/help/string-to-list000644 001751 001751 00000000534 11203547234 014576 0ustar00nmhnmh000000 000000 R4RS 6.7 (string->list string) ==> list (list->string chars) ==> string STRING->LIST returns a newly allocated list of the characters that make up the given string. LIST->STRING returns a newly allocated string formed from the characters in the list CHARS. STRING->LIST and LIST->STRING are inverses so far as EQUAL? is concerned. s9/help/list-to-string000755 001751 001751 00000000000 12245077725 017421 2string-to-listustar00nmhnmh000000 000000 s9/help/string-copy000644 001751 001751 00000000141 11203552051 014140 0ustar00nmhnmh000000 000000 R4RS 6.7 (string-copy string) ==> string Returns a newly allocated copy of the given string. s9/help/string-fillb000644 001751 001751 00000000212 11203552066 014263 0ustar00nmhnmh000000 000000 R4RS 6.7 (string-fill! string char) ==> unspecific Stores CHAR in every element of the given STRING and returns an unspecified value. s9/help/vectorp000644 001751 001751 00000000142 11203554231 013347 0ustar00nmhnmh000000 000000 R4RS 6.8 (vector? object) ==> boolean Returns #T if OBJECT is a vector, otherwise returns #F. s9/help/make-vector000644 001751 001751 00000000446 11431711106 014110 0ustar00nmhnmh000000 000000 R4RS 6.8 (make-vector integer) ==> vector (make-vector integer object) ==> vector Returns a newly allocated vector of INTEGER elements. If a second argument is given, then each element is initialized to fill. Otherwise the initial content of each element is unspecified. s9/help/vector000644 001751 001751 00000000256 11203553064 013200 0ustar00nmhnmh000000 000000 R4RS 6.8 (vector object ...) ==> vector Returns a newly allocated vector whose elements contain the given arguments. Analogous to LIST. (vector 'a 'b 'c) ==> #(a b c) s9/help/vector-length000644 001751 001751 00000000132 11203554041 014444 0ustar00nmhnmh000000 000000 R4RS 6.8 (vector-length vector) ==> integer Returns the number of elements in VECTOR. s9/help/vector-ref000644 001751 001751 00000000337 11431711125 013747 0ustar00nmhnmh000000 000000 R4RS 6.8 (vector-ref vector integer) ==> object INTEGER must be a valid index of VECTOR. VECTOR-REF returns the contents of the element at the INTEGER'th position of VECTOR. (vector-ref '#(1 1 2 3 5 8 13 21) 5) ==> 8 s9/help/vector-setb000644 001751 001751 00000000713 11431711127 014130 0ustar00nmhnmh000000 000000 R4RS 6.8 (vector-set! vector integer object) ==> unspecific INTEGER must be a valid index of VECTOR. VECTOR-SET! stores OBJECT in the element at the INTEGER'th position of VECTOR. The value returned by VECTOR-SET! is unspecified. (let ((vec (vector 0 '(2 2 2 2) "Anna"))) (vector-set! vec 1 '("Sue" "Sue")) vec) ==> #(0 ("Sue" "Sue") "Anna") (vector-set! '#(0 1 2) 1 "doe") ==> error ; constant vector s9/help/vector-to-list000644 001751 001751 00000000601 11203547254 014567 0ustar00nmhnmh000000 000000 R4RS 6.8 (vector->list vector) ==> list (list->vector list) ==> vector VECTOR->LIST returns a newly allocated list of the objects contained in the elements of VECTOR. LIST->VECTOR returns a newly created vector initialized to the elements of the list LIST. (vector->list '#(dah dah didah)) ==> (dah dah didah) (list->vector '(dididit dah)) ==> #(dididit dah) s9/help/list-to-vector000755 001751 001751 00000000000 12245077725 017411 2vector-to-listustar00nmhnmh000000 000000 s9/help/vector-fillb000644 001751 001751 00000000226 11203553112 014255 0ustar00nmhnmh000000 000000 R4RS 6.8 (vector-fill! vector object) ==> unspecific Stores OBJECT in every element of VECTOR. The value returned by VECTOR-FILL! is unspecified. s9/help/procedurep000644 001751 001751 00000000431 11203551251 014035 0ustar00nmhnmh000000 000000 R4RS 6.9 (procedure? object) ==> boolean Returns #T if OBJECT is a procedure, otherwise returns #F. (procedure? car) ==> #t (procedure? 'car) ==> #f (procedure? (lambda (x) (* x x))) ==> #t (procedure? '(lambda (x) (* x x))) ==> #f s9/help/apply000644 001751 001751 00000000775 11203475033 013030 0ustar00nmhnmh000000 000000 R4RS 6.8 (apply procedure list) ==> object (apply procedure object ... list) ==> object The first form calls PROCEDURE with the elements of LIST as the actual arguments. The second form is a generalization of the first that calls PROCEDURE with the elements of the list (append (list object ...) LIST) as the actual arguments. (apply + (list 3 4)) ==> 7 (define (compose f g) (lambda args (f (apply g args))))) ((compose - *) 5 7) ==> -35 s9/help/map000644 001751 001751 00000001410 11203547660 012451 0ustar00nmhnmh000000 000000 R4RS 6.9 (map procedure list1 list2 ...) ==> list The LISTs must be lists, and PROCEDURE must be a procedure taking as many arguments as there are lists. If more than one list is given, then they must all be the same length. Map applies PROCEDURE element-wise to the elements of the lists and returns a list of the results, in order from left to right. The dynamic order in which PROCEDURE is applied to the elements of the lists is unspecified. (map cadr '((a b) (d e) (g h))) ==> (b e h) (map (lambda (n) (expt n n)) '(1 2 3 4 5)) ==> (1 4 27 256 3125) (map + '(1 2 3) '(4 5 6)) ==> (5 7 9) (let ((count 0)) (map (lambda (ignored) (set! count (+ count 1)) count) '(a b c))) ==> unspecified s9/help/for-each000644 001751 001751 00000001056 11203546327 013365 0ustar00nmhnmh000000 000000 R4RS 6.9 (for-each procedure list1 list2 ...) ==> unspecific The arguments to FOR-EACH are like the arguments to MAP, but FOR-EACH calls PROCEDURE for its side effects rather than for its values. Unlike MAP, FOR-EACH is guaranteed to call PROCEDURE on the elements of the lists in order from the first element to the last, and the value returned by FOR-EACH is unspecified. (let ((v (make-vector 5))) (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v) ==> #(0 1 4 9 16) s9/help/force000644 001751 001751 00000005757 11203554760 013013 0ustar00nmhnmh000000 000000 R4RS 6.9 (force promise) ==> object (delay expression) ==> promise FORCE forces the value of PROMISE (see DELAY, section see section 4.2.5 Delayed evaluation). If no value has been computed for the promise, then a value is computed and returned. The value of the promise is cached (or "memoized") so that if it is forced a second time, the previously computed value is returned. (force (delay (+ 1 2))) ==> 3 (let ((p (delay (+ 1 2)))) (list (force p) (force p))) ==> (3 3) (define a-stream (letrec ((next (lambda (n) (cons n (delay (next (+ n 1))))))) (next 0))) (define head car) (define (tail stream) (force (cdr stream))) (head (tail (tail a-stream))) ==> 2 FORCE and DELAY are mainly intended for programs written in functional style. The following examples should not be considered to illustrate good programming style, but they illustrate the property that only one value is computed for a promise, no matter how many times it is forced. (define count 0) (define p (delay (begin (set! count (+ count 1)) (if (> count x) count (force p))))) (define x 5) p ==> a promise (force p) ==> 6 p ==> a promise, still (begin (set! x 10) (force p)) ==> 6 Here is a possible implementation of DELAY and FORCE. Promises are implemented here as procedures of no arguments, and FORCE simply calls its argument: (define force (lambda (object) (object))) We define the expression (delay ) to have the same meaning as the procedure call (make-promise (lambda () )), where make-promise is defined as follows: (define (make-promise proc) (let ((result-ready? #f) (result #f)) (lambda () (if result-ready? result (let ((x (proc))) (if result-ready? result (begin (set! result-ready? #t) (set! result x) result))))))) Rationale: A promise may refer to its own value, as in the last example above. Forcing such a promise may cause the promise to be forced a second time before the value of the first FORCE has been computed. This complicates the definition of make-promise. Various extensions to this semantics of DELAY and FORCE are supported in some implementations: - Calling FORCE on an object that is not a promise may simply return the object. - It may be the case that there is no means by which a promise can be operationally distinguished from its forced value. That is, expressions like the following may evaluate to either #T or to #F, depending on the implementation: (eqv? (delay 1) 1) ==> unspecified (pair? (delay (cons 1 2))) ==> unspecified - Some implementations may implement "implicit forcing," where the value of a promise is forced by primitive procedures like cdr and +: (+ (delay (* 3 7)) 13) ==> 34 S9fES does not implement implicit forcing. s9/help/delay000755 001751 001751 00000000000 12245077725 014017 2forceustar00nmhnmh000000 000000 s9/help/call-with-input-file000644 001751 001751 00000001505 11203542034 015625 0ustar00nmhnmh000000 000000 R4RS 6.10 (call-with-input-file string procedure^1) ==> object (call-with-output-file string procedure^1) ==> object PROCEDURE^1 should be a procedure of one argument, and STRING should be a string naming a file. For CALL-WITH-INPUT-FILE, the file must already exist; for CALL-WITH-OUTPUT-FILE, the effect is unspecified if the file already exists. These procedures call PROCEDURE^1 with one argument: the port obtained by opening the named file for input or output. If the file cannot be opened, an error is signalled. If the procedure returns, then the port is closed automatically and the value yielded by the procedure is returned. If the procedure does not return, then the port will not be closed automatically unless it is possible to prove that the port will never again be used for a read or write operation. s9/help/call-with-output-file000755 001751 001751 00000000000 12245077725 021720 2call-with-input-fileustar00nmhnmh000000 000000 s9/help/input-portp000644 001751 001751 00000000270 11203546625 014200 0ustar00nmhnmh000000 000000 R4RS 6.10 (input-port? object) ==> boolean (output-port? object) ==> boolean Returns #T if OBJECT is an input port or output port respectively, otherwise returns #F. s9/help/accept-keywords000755 001751 001751 00000000000 12245077725 017525 2keyword-valueustar00nmhnmh000000 000000 s9/help/current-input-port000644 001751 001751 00000000230 11203543450 015465 0ustar00nmhnmh000000 000000 R4RS 6.10 (current-input-port) ==> input-port (current-output-port) ==> output-port Returns the current default input or output port. s9/help/with-input-from-file000644 001751 001751 00000001333 11203554340 015657 0ustar00nmhnmh000000 000000 R4RS 6.10 (with-input-from-file string procedure^0) ==> object (with-output-to-file string procedure^0) ==> object PROCEDURE^0 must be a procedure of no arguments, and STRING must be a string naming a file. For WITH-INPUT-FROM-FILE, the file must already exist; for WITH-OUTPUT-TO-FILE, the effect is unspecified if the file already exists. The file is opened for input or output, an input or output port connected to it is made the default value returned by CURRENT-INPUT-PORT or CURRENT-OUTPUT-PORT, and the thunk is called with no arguments. When the thunk returns, the port is closed and the previous default is restored. WITH-INPUT-FROM-FILE and WITH-OUTPUT-TO-FILE return the value yielded by PROCEDURE^0. s9/help/with-output-to-file000755 001751 001751 00000000000 12245077725 021457 2with-input-from-fileustar00nmhnmh000000 000000 s9/help/open-input-file000644 001751 001751 00000000336 11203550642 014707 0ustar00nmhnmh000000 000000 R4RS 6.10 (open-input-file filename) ==> input-port Takes a string naming an existing file and returns an input port capable of delivering characters from the file. If the file cannot be opened, an error is signalled. s9/help/open-output-file000644 001751 001751 00000000500 11203550654 015104 0ustar00nmhnmh000000 000000 R4RS 6.10 (open-output-file filename) ==> output-port Takes a string naming an output file to be created and returns an output port capable of writing characters to a new file by that name. If the file cannot be opened, an error is signalled. If a file with the given name already exists, the effect is unspecified. s9/help/close-input-port000644 001751 001751 00000000554 11203543311 015115 0ustar00nmhnmh000000 000000 R4RS 6.10 (close-input-port input-port) ==> unspecific (close-output-port output-port) ==> unspecific Closes the file associated with INPUT-PORT or OUTPUT-PORT respectively, rendering the port incapable of delivering or accepting characters. These routines have no effect if the file has already been closed. The value returned is unspecified. s9/help/close-output-port000755 001751 001751 00000000000 12245077725 020474 2close-input-portustar00nmhnmh000000 000000 s9/help/read000644 001751 001751 00000002062 12033047275 012612 0ustar00nmhnmh000000 000000 R4RS 6.10.2 (read) ==> object (read input-port) ==> object READ converts external representations of Scheme objects into the objects themselves. That is, it is a parser for the nonterminal (see sections see section 7.1.2 External representations and see section 6.3 Pairs and lists). READ returns the next object parsable from the given input port, updating port to point to the first character past the end of the external representation of the object. If an end of file is encountered in the input before any characters are found that can begin an object, then an end of file object is returned. The port remains open, and further attempts to read will also return an end of file object. If an end of file is encountered after the beginning of an object's external representation, but the external representation is incomplete and therefore not parsable, an error is signalled. The INPUT-PORT argument may be omitted, in which case it defaults to the value returned by CURRENT-INPUT-PORT. It is an error to read from a closed port. s9/help/read-char000644 001751 001751 00000000624 11203551360 013520 0ustar00nmhnmh000000 000000 R4RS 6.10.2 (read-char) ==> char | eof-object (read-char input-port) ==> char | eof-object Returns the next character available from the input port, updating the port to point to the following character. If no more characters are available, an end of file object is returned. INPUT-PORT may be omitted, in which case it defaults to the value returned by CURRENT-INPUT-PORT. s9/help/peek-char000644 001751 001751 00000001514 11203551064 013531 0ustar00nmhnmh000000 000000 R4RS 6.10.2 (peek-char) ==> char | eof-object (peek-char input-port) ==> char | eof-object Returns the next character available from the input port, without updating the port to point to the following character. If no more characters are available, an end of file object is returned. INPUT-PORT may be omitted, in which case it defaults to the value returned by CURRENT-INPUT-PORT. Note: The value returned by a call to PEEK-CHAR is the same as the value that would have been returned by a call to READ-CHAR with the same port. The only difference is that the very next call to READ-CHAR or PEEK-CHAR on that port will return the value returned by the preceding call to PEEK-CHAR. In particular, a call to PEEK-CHAR on an interactive port will hang waiting for input whenever a call to READ-CHAR would have hung. s9/help/eof-objectp000644 001751 001751 00000000433 11203545017 014067 0ustar00nmhnmh000000 000000 R4RS 6.10.2 (eof-object? object) ==> boolean Returns #T if OBJECT is an end of file object, otherwise returns #F. The precise set of end of file objects will vary among implementations, but in any case no end of file object will ever be an object that can be read in using read. s9/help/write000644 001751 001751 00000000761 12033047553 013034 0ustar00nmhnmh000000 000000 R4RS 6.10.3 (write object) ==> unspecific (write object output-port) ==> unspecific Writes a written representation of OBJECT to the given port. Strings that appear in the written representation are enclosed in double quotes, and within those strings backslash and double quote characters are escaped by backslashes. WRITE returns an unspecified value. The OUTPUT-PORT argument may be omitted, in which case it defaults to the value returned by CURRENT-OUTPUT-PORT. s9/help/display000644 001751 001751 00000001470 12033046502 013336 0ustar00nmhnmh000000 000000 R4RS 6.10.3 (display object) ==> unspecific (display object output-port) ==> unspecific Writes a representation of OBJECT to the given OUTPUT-PORT. Strings that appear in the written representation are not enclosed in double quotes, and no characters are escaped within those strings. Character objects appear in the representation as if written by write-char instead of by write. DISPLAY returns an unspecified value. The OUTPUT-PORT argument may be omitted, in which case it defaults to the value returned by CURRENT-OUTPUT-PORT. Rationale: WRITE is intended for producing machine-readable output and DISPLAY is for producing human-readable output. Implementations that allow "slashification" within symbols will probably want WRITE but not DISPLAY to slashify funny characters in symbols. s9/help/newline000644 001751 001751 00000000545 11203550401 013330 0ustar00nmhnmh000000 000000 R4RS 6.10.3 (newline) ==> unspecific (newline output-port) ==> unspecific Writes an end of line to OUTPUT-PORT. Exactly how this is done differs from one operating system to another. Returns an unspecified value. The OUTPUT-PORT argument may be omitted, in which case it defaults to the value returned by CURRENT-OUTPUT-PORT. s9/help/write-char000644 001751 001751 00000000552 11203554451 013743 0ustar00nmhnmh000000 000000 R4RS 6.10.3 (write-char char) ==> unspecific (write-char char output-port) ==> unspecific Writes the character CHAR (not an external representation of the character) to the given port and returns an unspecified value. The OUTPUT-PORT argument may be omitted, in which case it defaults to the value returned by CURRENT-OUTPUT-PORT. s9/help/load000644 001751 001751 00000001104 11203547355 012614 0ustar00nmhnmh000000 000000 R4RS 6.10.4 (load string) ==> unspecific STRING should be a file name naming an existing file containing Scheme source code. The LOAD procedure reads expressions and definitions from the file and evaluates them sequentially. It is unspecified whether the results of the expressions are printed. The LOAD procedure does not affect the values returned by CURRENT-INPUT-PORT and CURRENT-OUTPUT-PORT. LOAD returns an unspecified value. Rationale: For portability, LOAD must operate on source files. Its operation on other kinds of files necessarily varies among implementations. s9/help/curs_get-magic-value000755 001751 001751 00000000000 12245077725 020111 2curs_cbreakustar00nmhnmh000000 000000 s9/help/macro-expand-1000755 001751 001751 00000000000 12245077725 016715 2macro-expandustar00nmhnmh000000 000000 s9/help/file-existsp000644 001751 001751 00000000202 11203545774 014312 0ustar00nmhnmh000000 000000 S9fES (file-exists? string) ==> boolean Return #T if the file specifed in the STRING argument exists and otherwise return #F. s9/help/fold-left000644 001751 001751 00000001632 11203546157 013556 0ustar00nmhnmh000000 000000 S9fES (fold-left procedure object list ...) ==> object Fold a series of lists by combining the result so far with adjacent members of the given LISTs by PROCEDURE. PROCEDURE must by a K-ary procedure where K is the number of lists passed to FOLD-LEFT plus one. OBJECT is the base element that is used in the place of the intermediate result in the first application of PROCEDURE. FOLD-LEFT folds lists by grouping applications of PROCEDURE to the left. Applications of FOLD-LEFT can be rewritten as follows: (fold-left p2 0 (a b)) == (p2 (p2 0 a) b) (fold-left p3 0 (a b) (c d)) == (p3 (p3 0 a c) b d) (fold-left p4 0 (a b) (c d) (e f)) == (p4 (p4 0 a c e) b d f) (fold-left cons 0 '(1 2 3)) ==> (((0 . 1) . 2) . 3) (fold-left list 0 '(1 2) '(3 4) '(5 6)) ==> ((0 1 3 5) 2 4 6) (fold-left + 0 '(1 2 3)) ==> 6 (fold-left - 0 '(1 2 3)) ==> -6 s9/help/fold-right000644 001751 001751 00000001650 11203546262 013736 0ustar00nmhnmh000000 000000 S9fES (fold-right procedure object list ...) ==> object Fold a set of lists by combining the result so far with adjacent members of the given LISTs by PROCEDURE. PROCEDURE must by a K-ary procedure where K is the number of lists passed to FOLD-RIGHT plus one. OBJECT is the base element that is combined with the intermediate result in the last application of PROCEDURE. FOLD-RIGHT folds lists by grouping applications of PROCEDURE to the right. Applications of FOLD-RIGHT can be rewritten as follows: (fold-right p2 0 (a b)) == (p2 a (p2 b 0)) (fold-right p3 0 (a b) (c d)) == (p3 a c (p3 b d 0)) (fold-right p4 0 (a b) (c d) (e f)) == (p4 a c e (p4 b d f 0)) (fold-right cons 0 '(1 2 3)) ==> (1 2 3 . 0) (fold-right list 0 '(1 2) '(3 4) '(5 6)) ==> (1 3 5 (2 4 6 0)) (fold-right + 0 '(1 2 3)) ==> 6 (fold-right - 0 '(1 2 3)) ==> 2 ; (- 1 (- 2 (- 3 0))) s9/help/gensym000644 001751 001751 00000000674 12046421105 013200 0ustar00nmhnmh000000 000000 S9fES (gensym symbol) ==> symbol (gensym string) ==> symbol (gensym) ==> symbol Return a fresh symbol that is guaranteed to be unique. When SYMBOL or STRING is passed to GENSYM, the returned symbol will have its characters as a prefix. (gensym) ==> g56 (gensym "foo") ==> foo57 (gensym 'bar) ==> bar58 (let ((a (gensym)) (b (gensym)) (c (gensym))) (list a b c)) ==> (g63 g62 g61) s9/help/load-from-library000644 001751 001751 00000000557 11203547402 015223 0ustar00nmhnmh000000 000000 S9fES (load-from-library string) ==> unspecific Locate the Scheme source file whose name is specified in STRING and load it. It is an error to specify a file that cannot be located. LOAD-FROM-LIBRARY uses LOCATE-FILE to locate a file and LOAD to load it. It is intended to load files from extension libraries that may be stored in a set of pre-defined locations. s9/help/locate-file000644 001751 001751 00000001771 11203547513 014067 0ustar00nmhnmh000000 000000 S9fES (locate-file string) ==> string | #f Attempt to locate the file specified in STRING in a pre-defined set of directories. The directories to search are stored in the *LIBRARY-PATH* variable as a colon-separated list of paths. LOCATE-FILE appends a slash (/) and the given file name to each path of *LIBRARY-PATH* and then checks the existence of the resulting fully qualified file name by using FILE-EXISTS?. It returns the first fully qualified file name that exists or #F in case the file could not be located. ; Given *LIBRARY-PATH* == .:/u/s9fes ; and hello.scm in /u/s9fes/examples (locate-file "examples/hello.scm") ==> "/u/s9fes/examples/hello.scm" (locate-file "non-existent") ==> #f Rationale: LOCATE-FILE is intended to locate files that belong to the S9fES system, like extension library files, user library files, and help files. The value of *LIBRARY-PATH* is initialized when the Scheme system starts up, for example by copying it from the S9FES_LIBRARY_PATH environment variable. s9/help/print000644 001751 001751 00000000530 11203551233 013021 0ustar00nmhnmh000000 000000 S9fES (print object ...) ==> unspecific Write the external representation of each given OBJECT to the port returned by CURRENT-OUTPUT-PORT. Use WRITE to write each external representation. Display one space character between adjacent objects. Display a newline sequence after the last object. PRINT with no arguments is equal to (NEWLINE). s9/help/set-input-portb000644 001751 001751 00000000365 11203551452 014752 0ustar00nmhnmh000000 000000 S9fES (set-input-port! input-port) ==> unspecific (set-output-port! output-port) ==> unspecific Change the default input and output ports by mutating the values returned by CURRENT-INPUT-PORT and CURRENT-OUTPUT-PORT respectively. s9/help/symbols000644 001751 001751 00000000117 11203553025 013357 0ustar00nmhnmh000000 000000 S9fES (symbols) ==> list Return a list of all symbols known to the system. s9/help/begin000644 001751 001751 00000001045 11203542541 012755 0ustar00nmhnmh000000 000000 R4RS 4.2.3 (begin ...) ==> object The s are evaluated sequentially from left to right, and the value of the last expression is returned. This expression type is used to sequence side effects such as input and output. (define x 0) (begin (set! x 5) (+ x 1)) ==> 6 (begin (display "4 plus 1 equals ") (display (+ 4 1))) ==> unspecific ; side effect: print 4 plus 1 equals 5 S9fES allows BEGIN to take zero arguments, returning an unspecific value. s9/help/case000644 001751 001751 00000002514 11203542560 012607 0ustar00nmhnmh000000 000000 R4RS 4.2.1 (case ...) ==> object Syntax: may be any expression. Each should have the form (( ...) ...), where each is an external representation of some object. All the s must be distinct. The last may be an "else clause," which has the form (else ...). Semantics: A CASE expression is evaluated as follows. is evaluated and its result is compared against each . If the result of evaluating is equivalent (in the sense of EQV?; see section see section 6.2 Equivalence predicates) to a , then the expressions in the corresponding are evaluated from left to right and the result of the last expression in the is returned as the result of the CASE expression. If the result of evaluating is different from every , then if there is an ELSE clause its expressions are evaluated and the result of the last is the result of the case expression; otherwise the result of the CASE expression is unspecified. (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite)) ==> composite (case (car '(c d)) ((a) 'a) ((b) 'b)) ==> unspecific (case (car '(c d)) ((a e i o u) 'vowel) ((w y) 'semivowel) (else 'consonant)) ==> consonant s9/help/cond000644 001751 001751 00000003160 11203543404 012613 0ustar00nmhnmh000000 000000 R4RS 4.2.1 (cond ...) ==> object Syntax: Each should be of the form ( ...) where is any expression. The last may be an "else clause," which has the form (else ...). Semantics: A COND expression is evaluated by evaluating the expressions of successive s in order until one of them evaluates to a true value (see section see section 6.1 Booleans). When a evaluates to a true value, then the remaining s in its are evaluated in order, and the result of the last in the is returned as the result of the entire COND expression. If the selected contains only the and no s, then the value of the is returned as the result. If all s evaluate to false values, and there is no ELSE clause, then the result of the conditional expression is unspecified; if there is an ELSE clause, then its s are evaluated, and the value of the last one is returned. (cond ((> 3 2) 'greater) ((< 3 2) 'less)) ==> greater (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal)) ==> equal Some implementations support an alternative syntax, ( => ), where is an expression. If evaluates to a true value, then is evaluated. Its value must be a procedure of one argument; this procedure is then invoked on the value of the . (cond ((assv 'b '((a 1) (b 2))) => cadr) (else #f)) ==> 2 S9fES does support the alternative clause syntax. s9/help/define000644 001751 001751 00000005422 11414544261 013133 0ustar00nmhnmh000000 000000 R4RS 5.2 (define ) ==> unspecific (define ( ) ) ==> unspecific (define ( . ) ) ==> unspecific Definitions are valid in some, but not all, contexts where expressions are allowed. They are valid only at the top level of a and, in some implementations, at the beginning of a . A definition should have one of the following forms: - (define ) - (define ( ) ) should be either a sequence of zero or more variables, or a sequence of one or more variables followed by a space-delimited period and another variable (as in a lambda expression). This form is equivalent to (define (lambda () )). - (define ( . ) ) should be a single variable. This form is equivalent to (define (lambda )). - (begin ...) This form is equivalent to the set of definitions that form the body of the begin. 5.2.1 Top level definitions At the top level of a program, a definition (define ) has essentially the same effect as the assignment expression (set! ) if is bound. If is not bound, however, then the definition will bind to a new location before performing the assignment, whereas it would be an error to perform a set! on an unbound variable. (define add3 (lambda (x) (+ x 3))) (add3 3) ==> 6 (define first car) (first '(1 2)) ==> 1 5.2.2 Internal definitions Some implementations of Scheme permit definitions to occur at the beginning of a (that is, the body of a LAMBDA, LET, LET*, LETREC, or DEFINE expression). Such definitions are known as internal definitions as opposed to the top level definitions described above. The variable defined by an internal definition is local to the . That is, is bound rather than assigned, and the region of the binding is the entire . For example, (let ((x 5)) (define foo (lambda (y) (bar x y))) (define bar (lambda (a b) (+ (* a b) a))) (foo (+ x 3))) ==> 45 A containing internal definitions can always be converted into a completely equivalent LETREC expression. For example, the let expression in the above example is equivalent to (let ((x 5)) (letrec ((foo (lambda (y) (bar x y))) (bar (lambda (a b) (+ (* a b) a)))) (foo (+ x 3)))) Just as for the equivalent LETREC expression, it must be possible to evaluate each of every internal definition in a without assigning or referring to the value of any being defined. S9fES does support local definitions. s9/help/do000644 001751 001751 00000003626 11775332625 012320 0ustar00nmhnmh000000 000000 R4RS 4.2.4 (do ) ==> object More specifically, the DO syntax is: (do (( ) ...) ( ...) ...) DO is an iteration construct. It specifies a set of variables to be bound, how they are to be initialized at the start, and how they are to be updated on each iteration. When a termination condition is met, the loop exits with a specified result value. DO expressions are evaluated as follows: The expressions are evaluated (in some unspecified order), the s are bound to fresh locations, the results of the expressions are stored in the bindings of the s, and then the iteration phase begins. Each iteration begins by evaluating ; if the result is false (see section see section 6.1 Booleans), then the expressions are evaluated in order for effect, the expressions are evaluated in some unspecified order, the s are bound to fresh locations, the results of the s are stored in the bindings of the s, and the next iteration begins. If evaluates to a true value, then the s are evaluated from left to right and the value of the last is returned as the value of the DO expression. If no s are present, then the value of the DO expression is unspecified. The region of the binding of a consists of the entire DO expression except for the s. It is an error for a to appear more than once in the list of DO variables. A may be omitted, in which case the effect is the same as if `( )' had been written instead of `( )'. (do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i)) ==> #(0 1 2 3 4) (let ((x '(1 3 5 7 9))) (do ((x x (cdr x)) (sum 0 (+ sum (car x)))) ((null? x) sum))) ==> 25 s9/help/if000644 001751 001751 00000001275 11203546604 012300 0ustar00nmhnmh000000 000000 R4RS 4.1.5 (if ) ==> object (if ) ==> object Syntax: , , and may be arbitrary expressions. Semantics: An IF expression is evaluated as follows: first, is evaluated. If it yields a true value (see section see section 6.1 Booleans), then is evaluated and its value is returned. Otherwise is evaluated and its value is returned. If yields a false value and no is specified, then the result of the expression is unspecified. (if (> 3 2) 'yes 'no) ==> yes (if (> 2 3) 'yes 'no) ==> no (if (> 3 2) (- 3 2) (+ 3 2)) ==> 1 s9/help/lambda000644 001751 001751 00000004352 11775333146 013132 0ustar00nmhnmh000000 000000 R4RS 4.1.4 (lambda ) ==> procedure Syntax: should be a formal arguments list as described below, and should be a sequence of one or more expressions. Semantics: A LAMBDA expression evaluates to a procedure. The environment in effect when the LAMBDA expression was evaluated is remembered as part of the procedure. When the procedure is later called with some actual arguments, the environment in which the LAMBDA expression was evaluated will be extended by binding the variables in the formal argument list to fresh locations, the corresponding actual argument values will be stored in those locations, and the expressions in the body of the LAMBDA expression will be evaluated sequentially in the extended environment. The result of the last expression in the body will be returned as the result of the procedure call. (lambda (x) (+ x x)) ==> a procedure ((lambda (x) (+ x x)) 4) ==> 8 (define reverse-subtract (lambda (x y) (- y x))) (reverse-subtract 7 10) ==> 3 (define add4 (let ((x 4)) (lambda (y) (+ x y)))) (add4 6) ==> 10 should have one of the following forms: - ( ...): The procedure takes a fixed number of arguments; when the procedure is called, the arguments will be stored in the bindings of the corresponding variables. - : The procedure takes any number of arguments; when the procedure is called, the sequence of actual arguments is converted into a newly allocated list, and the list is stored in the binding of the . - ( ... . ): If a space-delimited period precedes the last variable, then the value stored in the binding of the last variable will be a newly allocated list of the actual arguments left over after all the other actual arguments have been matched up against the other formal arguments. It is an error for a to appear more than once in . ((lambda x x) 3 4 5 6) ==> (3 4 5 6) ((lambda (x y . z) z) 3 4 5 6) ==> (5 6) Each procedure created as the result of evaluating a LAMBDA expression is tagged with a storage location, in order to make EQV? and EQ? work on procedures (see section see section 6.2 Equivalence predicates). s9/help/let000644 001751 001751 00000003322 11775333304 012466 0ustar00nmhnmh000000 000000 R4RS 4.2.2 (let ) ==> object Syntax: should have the form (( ) ...), where each is an expression, and should be a sequence of one or more expressions. It is an error for a to appear more than once in the list of variables being bound. Semantics: The s are evaluated in the current environment (in some unspecified order), the s are bound to fresh locations holding the results, the is evaluated in the extended environment, and the value of the last expression of is returned. Each binding of a has as its region. (let ((x 2) (y 3)) (* x y)) ==> 6 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))) ==> 35 4.2.4 (let ) ==> object Some implementations of Scheme permit a variant on the syntax of LET called "named let" which provides a more general looping construct than DO, and may also be used to express recursions. Named LET has the same syntax and semantics as ordinary LET except that is bound within to a procedure whose formal arguments are the bound variables and whose body is . Thus the execution of may be repeated by invoking the procedure named by . (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) (cond ((null? numbers) (list nonneg neg)) ((>= (car numbers) 0) (loop (cdr numbers) (cons (car numbers) nonneg) neg)) ((< (car numbers) 0) (loop (cdr numbers) nonneg (cons (car numbers) neg))))) ==> ((6 1 3) (-5 -2)) S9fES does support named LET. s9/help/quasiquote000644 001751 001751 00000004620 11440124402 014066 0ustar00nmhnmh000000 000000 R4RS 4.2.6 (quasiquote