From 8ffbc2df0fde83082610149d24e594c1cd879f4a Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 2a6 --- ANNOUNCE | 70 + ChangeLog | 1094 +++++++ FAQ | 216 ++ Makefile | 229 ++ README | 220 ++ Template.scm | 267 ++ alist.scm | 66 + alistab.scm | 227 ++ array.scm | 279 ++ arraymap.scm | 76 + batch.scm | 417 +++ break.scm | 151 + chap.scm | 150 + charplot.scm | 142 + chez.init | 266 ++ cltime.scm | 74 + collect.scm | 236 ++ comlist.scm | 326 ++ comparse.scm | 92 + dbrowse.scm | 98 + dbutil.scm | 222 ++ debug.scm | 78 + defmacex.scm | 96 + dwindtst.scm | 80 + dynamic.scm | 75 + dynwind.scm | 74 + elk.init | 281 ++ factor.scm | 149 + fluidlet.scm | 45 + format.scm | 1678 +++++++++++ formatst.scm | 647 ++++ gambit.init | 219 ++ genwrite.scm | 264 ++ getopt.scm | 80 + hash.scm | 153 + hashtab.scm | 79 + lineio.scm | 50 + logical.scm | 150 + macrotst.scm | 54 + macscheme.init | 265 ++ macwork.scm | 126 + makcrc.scm | 86 + mbe.scm | 362 +++ mitcomp.pat | 1466 +++++++++ mitscheme.init | 254 ++ modular.scm | 158 + mulapply.scm | 28 + mularg.scm | 10 + mwdenote.scm | 273 ++ mwexpand.scm | 548 ++++ mwsynrul.scm | 343 +++ obj2str.scm | 61 + object.scm | 97 + paramlst.scm | 215 ++ plottest.scm | 47 + pp.scm | 12 + ppfile.scm | 70 + primes.scm | 181 ++ printf.scm | 278 ++ priorque.scm | 141 + process.scm | 68 + promise.scm | 29 + qp.scm | 149 + queue.scm | 72 + r4rsyn.scm | 542 ++++ randinex.scm | 99 + random.scm | 101 + ratize.scm | 13 + rdms.scm | 598 ++++ recobj.scm | 54 + record.scm | 211 ++ repl.scm | 92 + report.scm | 116 + require.scm | 348 +++ root.scm | 149 + sc2.scm | 66 + sc4opt.scm | 53 + sc4sc3.scm | 35 + scaexpp.scm | 2956 ++++++++++++++++++ scaglob.scm | 32 + scainit.scm | 103 + scamacr.scm | 181 ++ scanf.scm | 351 +++ scaoutp.scm | 93 + scheme2c.init | 291 ++ scheme48.init | 239 ++ scmacro.scm | 119 + scmactst.scm | 160 + sierpinski.scm | 71 + slib.info | 153 + slib.info-1 | 1306 ++++++++ slib.info-2 | 1193 ++++++++ slib.info-3 | 859 ++++++ slib.info-4 | 1248 ++++++++ slib.info-5 | 1536 ++++++++++ slib.info-6 | 1410 +++++++++ slib.info-7 | 615 ++++ slib.info-8 | 570 ++++ slib.texi | 9058 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ sort.scm | 154 + soundex.scm | 82 + stdio.scm | 7 + strcase.scm | 45 + strport.scm | 51 + strsrch.scm | 95 + struct.scm | 165 ++ structst.scm | 37 + structure.scm | 80 + syncase.sh | 146 + synchk.scm | 104 + synclo.scm | 748 +++++ synrul.scm | 327 ++ t3.init | 425 +++ tek40.scm | 92 + tek41.scm | 147 + time.scm | 158 + trace.scm | 106 + tree.scm | 62 + trnscrpt.scm | 76 + tsort.scm | 46 + values.scm | 27 + vscm.init | 306 ++ withfile.scm | 82 + wttest.scm | 134 + wttree.scm | 784 +++++ yasyn.scm | 201 ++ 126 files changed, 44217 insertions(+) create mode 100644 ANNOUNCE create mode 100644 ChangeLog create mode 100644 FAQ create mode 100644 Makefile create mode 100644 README create mode 100644 Template.scm create mode 100644 alist.scm create mode 100644 alistab.scm create mode 100644 array.scm create mode 100644 arraymap.scm create mode 100644 batch.scm create mode 100644 break.scm create mode 100644 chap.scm create mode 100644 charplot.scm create mode 100644 chez.init create mode 100644 cltime.scm create mode 100644 collect.scm create mode 100644 comlist.scm create mode 100644 comparse.scm create mode 100644 dbrowse.scm create mode 100644 dbutil.scm create mode 100644 debug.scm create mode 100644 defmacex.scm create mode 100644 dwindtst.scm create mode 100644 dynamic.scm create mode 100644 dynwind.scm create mode 100644 elk.init create mode 100644 factor.scm create mode 100644 fluidlet.scm create mode 100644 format.scm create mode 100644 formatst.scm create mode 100644 gambit.init create mode 100644 genwrite.scm create mode 100644 getopt.scm create mode 100644 hash.scm create mode 100644 hashtab.scm create mode 100644 lineio.scm create mode 100644 logical.scm create mode 100644 macrotst.scm create mode 100644 macscheme.init create mode 100644 macwork.scm create mode 100644 makcrc.scm create mode 100644 mbe.scm create mode 100644 mitcomp.pat create mode 100644 mitscheme.init create mode 100644 modular.scm create mode 100644 mulapply.scm create mode 100644 mularg.scm create mode 100644 mwdenote.scm create mode 100644 mwexpand.scm create mode 100644 mwsynrul.scm create mode 100644 obj2str.scm create mode 100644 object.scm create mode 100644 paramlst.scm create mode 100644 plottest.scm create mode 100644 pp.scm create mode 100644 ppfile.scm create mode 100644 primes.scm create mode 100644 printf.scm create mode 100644 priorque.scm create mode 100644 process.scm create mode 100644 promise.scm create mode 100644 qp.scm create mode 100644 queue.scm create mode 100644 r4rsyn.scm create mode 100644 randinex.scm create mode 100644 random.scm create mode 100644 ratize.scm create mode 100644 rdms.scm create mode 100644 recobj.scm create mode 100644 record.scm create mode 100644 repl.scm create mode 100644 report.scm create mode 100644 require.scm create mode 100644 root.scm create mode 100644 sc2.scm create mode 100644 sc4opt.scm create mode 100644 sc4sc3.scm create mode 100644 scaexpp.scm create mode 100644 scaglob.scm create mode 100644 scainit.scm create mode 100644 scamacr.scm create mode 100644 scanf.scm create mode 100644 scaoutp.scm create mode 100644 scheme2c.init create mode 100644 scheme48.init create mode 100644 scmacro.scm create mode 100644 scmactst.scm create mode 100644 sierpinski.scm create mode 100644 slib.info create mode 100644 slib.info-1 create mode 100644 slib.info-2 create mode 100644 slib.info-3 create mode 100644 slib.info-4 create mode 100644 slib.info-5 create mode 100644 slib.info-6 create mode 100644 slib.info-7 create mode 100644 slib.info-8 create mode 100644 slib.texi create mode 100644 sort.scm create mode 100644 soundex.scm create mode 100644 stdio.scm create mode 100644 strcase.scm create mode 100644 strport.scm create mode 100644 strsrch.scm create mode 100644 struct.scm create mode 100644 structst.scm create mode 100644 structure.scm create mode 100644 syncase.sh create mode 100644 synchk.scm create mode 100644 synclo.scm create mode 100644 synrul.scm create mode 100644 t3.init create mode 100644 tek40.scm create mode 100644 tek41.scm create mode 100644 time.scm create mode 100644 trace.scm create mode 100644 tree.scm create mode 100644 trnscrpt.scm create mode 100644 tsort.scm create mode 100644 values.scm create mode 100644 vscm.init create mode 100644 withfile.scm create mode 100644 wttest.scm create mode 100644 wttree.scm create mode 100644 yasyn.scm diff --git a/ANNOUNCE b/ANNOUNCE new file mode 100644 index 0000000..f34c063 --- /dev/null +++ b/ANNOUNCE @@ -0,0 +1,70 @@ +This message announces the availability of Scheme Library release +slib2a6. + +New in SLIB2a6: + + * structure.scm scaoutp.scm scamacr.scm scainit.scm scaglob.scm + scaexpp.scm: Added missing copyright notice and terms. + + * rbtest.scm rbtree.scm: removed for lack of copying permissions. + + * root.scm (newton:find-integer-root integer-sqrt newton:find-root + laguerre:find-root laguerre:find-root): added. + + * scanf.scm (stdio:scan-and-set): removed gratuitous char-downcase + by changing all (next-format-char) ==> (read-char format-port). + +SLIB is a portable scheme library meant to provide compatibiliy and +utility functions for all standard scheme implementations. + +SLIB includes initialization files for Chez, ELK 2.1, GAMBIT, +MacScheme, MITScheme, scheme->C, Scheme48, T3.1, and VSCM. SCM also +supports SLIB. + +Documentation includes a manifest, installation instructions, and +coding standards for the library. Documentation on each library +package is supplied. SLIB Documentation is online at: + + http://ftp-swiss.ai.mit.edu/~jaffer/SLIB.html + +SLIB is a portable Scheme library: + ftp-swiss.ai.mit.edu:pub/scm/slib2a6.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/slib2a6.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2a6.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2a6.tar.gz + +SLIB-PSD is a portable debugger for Scheme (requires emacs editor): + ftp-swiss.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz + +SLIB-SCHELOG is an embedding of Prolog in Scheme: + ftp-swiss.ai.mit.edu:pub/scm/slib-schelog.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/slib-schelog.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-schelog.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-schelog.tar.gz + +Programs for printing and viewing TexInfo documentation (which SLIB +has) come with GNU Emacs or can be obtained via ftp from: +prep.ai.mit.edu:pub/gnu/texinfo-3.1.tar.gz + +Files in these directories are compressed with patent-free gzip (no +relation to zip). The program to uncompress them is available from + prep.ai.mit.edu:pub/gnu/gzip-1.2.4.tar + prep.ai.mit.edu:pub/gnu/gzip-1.2.4.shar + prep.ai.mit.edu:pub/gnu/gzip-1.2.4.msdos.exe + + ftp ftp-swiss.ai.mit.edu (anonymous) + bin + cd pub/scm + get slib2a6.tar.gz +or + ftp prep.ai.mit.edu (anonymous) + cd pub/gnu/jacal + bin + get slib2a6.tar.gz + + `slib2a6.tar.gz' is a compressed tar file of a Scheme Library. + +Remember to use binary mode when transferring the *.tar.gz files. diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..977f23e --- /dev/null +++ b/ChangeLog @@ -0,0 +1,1094 @@ +Fri Jul 19 11:24:45 1996 Aubrey Jaffer + + * structure.scm scaoutp.scm scamacr.scm scainit.scm scaglob.scm + scaexpp.scm: Added missing copyright notice and terms. + +Thu Jul 18 17:37:14 1996 Aubrey Jaffer + + * rbtest.scm rbtree.scm: removed for lack of copying permissions. + +Wed Jun 5 00:22:33 1996 Aubrey Jaffer + + * root.scm (newton:find-integer-root integer-sqrt newton:find-root + laguerre:find-root laguerre:find-root): added. + +Wed May 15 09:59:00 1996 Aubrey Jaffer + + * scanf.scm (stdio:scan-and-set): removed gratuitous char-downcase + by changing all (next-format-char) ==> (read-char format-port). + +Tue Apr 9 19:22:40 1996 Aubrey Jaffer + + * slib2a5 released. + + * mwtest.scm: removed from distribution for lack of copyright + info. + + * batch.scm (batch:apply-chop-to-fit): added + (batch:try-system): renamed from batch:system. + (batch:system): now signals error if line length over limit or + system calls fail. + +Sun Aug 20 19:20:35 1995 Gary Leavens + + * struct.scm (check-define-record-syntax check-variant-case-syntax): + + For using the file "struct.scm" with the EOPL book, one has to + make 2 corrections. To correct it, there are two places where "-" + has to be replaced by "->" as in the code below... + +Sat Apr 6 14:31:19 1996 Aubrey Jaffer + + * batch.scm (must-be-first must-be-last): added. + + * paramlst.scm (check-parameters): made error message more + informative. + +Mon Mar 18 08:46:36 1996 Aubrey Jaffer + + * modular.scm (modular:*): non-bignum symmetric modulus case was + dividing by 0. Algorithm still needs to be fixed. + +Mon Mar 13 00:41:00 1996 Aubrey Jaffer + + * slib2a4 released. + +Sat Mar 9 21:36:19 1996 Mikael Djurfeldt + + * tsort.scm (topological-sort): Added. + +Fri Mar 8 19:25:52 1996 Aubrey Jaffer + + * printf.scm: Removed use of string-ports. Cleaned up error + handling. + +Tue Mar 5 14:30:09 1996 Aubrey Jaffer + + * printf.scm (%a %A): General scheme output specifier added. + +Mon Feb 19 15:48:06 1996 Aubrey Jaffer + + * scanf.scm (stdio:scan-and-set): Removed flush-whitespace from + all conversion specifications per suggestion from + oleg@mozart.compsci.com (Oleg Kiselyov). + +Sat Feb 3 00:02:06 1996 Oleg Kiselyov (oleg@ponder.csci.unt.edu) + + * strsrch.scm (string-index substring? find-string-from-port?): added. + +Mon Jan 29 23:56:33 1996 Aubrey Jaffer + + * printf.scm (stdio:iprintf): Rewrote for Posix compliance (+ + extensions which are both BSD and GNU). + +Sat Jan 27 09:55:03 1996 Aubrey Jaffer + + * FAQ: printf vs. format explained. + + * printf.scm: renamed from "stdio.scm". (require 'printf) now + brings in "printf.scm". + +Sun Jan 14 21:00:17 1996 Aubrey Jaffer + + * scanf.scm: Rewrote from scratch. + +Mon Oct 9 22:48:58 1995 Aubrey Jaffer (jaffer@jacal) + + * modular.scm (modular:invertable?): added. + +Wed Sep 27 10:01:04 1995 Aubrey Jaffer (jaffer@jacal) + + * debug.scm: augmented, reorganized, and split. + (print): removed. + + * break.scm: created. + + * qp.scm: created. + +Sun Sep 24 22:23:19 1995 Aubrey Jaffer (jaffer@jacal) + + * require.scm (*catalog*): test.scm removed. + +Sun Sep 17 21:32:02 1995 Aubrey Jaffer (jaffer@jacal) + + * modular.scm: rewritten so that if modulus is: + positive? -- work as before (Z_modulus) + zero? -- perform integer operations (Z) + negative? -- perform operations using symmetric + representation (Z_(1-2*modulus)) + (symmetric:modulus modulus->integer modular:normalize): added. + (modular:*): not completed for fixnum-only implementations. + +Sat Sep 9 16:53:22 1995 Aubrey Jaffer (jaffer@jacal) + + * slib.texi (Legacy): added for t, nil, last-pair, and identity, + which are now required of all implementations. + +Mon Aug 28 00:42:29 1995 Aubrey Jaffer (jaffer@jacal) + + * require.scm (require:feature->path require:provided? + require:require): cleaned up. feature->path now returns a path, + whether the module is loaded or not. + +Sun Aug 27 11:05:19 1995 Aubrey Jaffer (jaffer@jacal) + + * genwrite.scm (generic-write): Fixed "obj2str" + OBJECT->LIMITED-STRING non-terminating wr-lst for cases like + (set-car! foo foo). + + * obj2str.scm (object->limited-string): uncommented. + +Sun Aug 20 17:10:40 1995 Stephen Adams + + * wttest.scm wttree.scm: Weight Balanced Trees added. + +Sun Aug 20 16:06:20 1995 Dave Love + + * tree.scm yasyn.scm collect.scm: Uppercase identifiers changed to + lower case for compatability with case sensitive implementations. + +Sat Aug 19 21:27:55 1995 Aubrey Jaffer (jaffer@jacal) + + * arraymap.scm (array-copy!): added. + + * primes.scm (primes:primes< primes:primes>): primes:primes split + into ascending and descending versions. + +Sun Jul 16 22:44:36 1995 Aubrey Jaffer (jaffer@jacal) + + * makcrc.scm (make-port-crc): added. POSIX.2 checksums. + +Mon Jun 12 16:20:54 1995 Aubrey Jaffer (jaffer@jacal) + + * synclo.scm (internal-syntactic-environment + top-level-syntactic-environment): replaced call to alist-copy. + + * require.scm (*catalog*): 'schelog, 'primes, and 'batch added. + 'prime renamed to 'factor. + + From: mhc@edsdrd.eds.com (Michael H Coffin) + * primes.scm (primes probably-prime?): added. prime.scm renamed + to factor.scm. + +Fri Mar 24 23:35:25 1995 Matthew McDonald + + * struct.scm (define-record): added field-setters. + +Sun Jun 11 23:36:55 1995 Aubrey Jaffer (jaffer@jacal) + + * batch.scm: added + + * Makefile (schelogfiles): SLIB schelog distribution created. + +Mon Apr 17 15:57:32 1995 Aubrey Jaffer (jaffer@jacal) + + * comlist.scm (coerce type-of): added. + + * debug.scm (debug:qp): with *qp-width* of 0 just `write's. + + * paramlst.scm (getopt->parameter-list): Now accepts long-named + options. Now COERCEs according to types. + +Sat Apr 15 23:15:26 1995 Aubrey Jaffer (jaffer@jacal) + + * require.scm (require:feature->path): Returns #f instead of + string if feature not in *catalog* or *modules*. + +Sun Mar 19 22:26:52 1995 Aubrey Jaffer (jaffer@jacal) + + * getopt.scm (getopt-- argc argv optstring): added wrapper for + getopt which parses long-named-options. + +Tue Feb 28 21:12:14 1995 Aubrey Jaffer (jaffer@jacal) + + * paramlst.scm (parameter-list-expand expanders parms): added. + +Mon Feb 27 17:23:54 1995 Aubrey Jaffer (jaffer@jacal) + + * report.scm (dbutil:print-report): added. + + * comparse.scm (read-command): added. Reads from a port and + returns a list of strings: the arguments (and options). + +Sat Feb 25 01:05:25 1995 Aubrey Jaffer (jaffer@jacal) + + * repl.scm (repl:repl): Added loop, conditional on CHAR-READY? + being PROVIDED?, which reads through trailing white-space. + +Sun Feb 5 16:34:03 1995 Aubrey Jaffer (jaffer@jacal) + + * paramlst.scm ((make-parameter-list parameter-names)): + ((fill-empty-parameters defaults parameter-list)): + ((check-parameters checks parameter-list)): + ((parameter-list->arglist positions arities parameter-list)): + ((parameter-list-ref parameter-list i)): + ((adjoin-parameters! parameter-list parameters)): + Procedures for making, merging, defaulting, checking and + converting `parameter lists' (named parameters). + ((getopt->parameter-list argc argv optnames arities aliases)): + ((getopt->arglist argc argv optnames positions + arities defaults checks aliases)): + Procedures for converting options and arguments processed by + getopt to parameter-list or arglist form. + + * dbutil.scm ((make-command-server rdb command-table)): added + procedure which calls commands and processes parameters. + + * rdms.scm ((make-relational-system base)): add-domain and + delete-domain commands moved to "dbutil.scm" (create-database). + +Fri Feb 3 11:07:46 1995 Aubrey Jaffer (jaffer@jacal) + + * debug.scm (debug:tracef debug:untracef): removed (duplicates of + code in "trace.scm"). + (trace-all): utility to trace all defines in a file added. + +Thu Jan 19 00:26:14 1995 Aubrey Jaffer (jaffer@jacal) + + * logical.scm (logbit? logtest): added. + +Sun Jan 15 20:38:42 1995 Aubrey Jaffer (jaffer@jacal) + + * dbutil.scm (dbutil:create-database)): Added parameter + description tables for "commands". + + * require.scm (software-type): standardize msdos -> ms-dos. + +Mon Jan 2 10:26:45 1995 Aubrey Jaffer (jaffer@jacal) + + * comlist.scm (comlist:atom?): renamed from comlist:atom. + + * scheme48.init (char->integer integer->char): Now use integers in + the range 0 to 255. Fixed several other problems. + (modulo): Worked around negative modulo bug. + + * Makefile (slib48): `make slib48' loads "scheme48.init", `,dump's + a scheme48 image file, and creates an `slib48' shell script to + invoke it. + + * hash.scm (hash:hash-number): no longer does inexact->exact to + exacts, etc. + + * trnscrpt.scm (read): no longer transcripts eof-objects. + + From: johnm@vlibs.com (John Gerard Malecki) + * priorque.scm (heap:heapify): internal defines incorrectly + dependent on order-of-eval replaced with let*. + +Thu Dec 22 13:28:16 1994 Aubrey Jaffer (jaffer@jacal) + + * dbutil.scm (open-database! open-database create-database): This + enhancement wraps a utility layer on `relational-database' which + provides: + * Automatic loading of the appropriate base-table package when + opening a database. + * Automatic execution of initialization commands stored in + database. + * Transparent execution of database commands stored in + `*commands*' table in database. + +Wed Dec 21 22:53:57 1994 Aubrey Jaffer (jaffer@jacal) + + * rdms.scm (make-relational-system base): Now more careful about + protecting read-only databases. + +Mon Dec 19 00:06:36 1994 Aubrey Jaffer (jaffer@jacal) + + * dbutil.scm (dbutil:define-tables): added utility which provides: + Data definition from Scheme lists for any SLIB + relational-database. + +Sat Dec 17 12:10:02 1994 Aubrey Jaffer (jaffer@jacal) + + * alistab.scm rdms.scm (make-getter row-eval): evaluation of + `expression' fields no longer done when retrieved from base + tables (which made copying of many tables impossible). + + * alistab.scm + (write-base): rewrote to not use pretty-print. + + * sc3.scm: removed (only contained last-pair, t, and nil). + + * Template.scm scheme48.init vscm.init (last-pair t nil): added. + +Thu Dec 8 00:02:18 1994 Aubrey Jaffer (jaffer@jacal) + + * mularg.scm pp.scm ratize.scm: copyright line removed from files + (still lacking terms) less than 12 lines. + + From: johnm@vlibs.com (John Gerard Malecki) + * sort.scm (sort:sort!): long standing bug in sort! with vector + argument fixed. + +Thu Dec 1 17:10:24 1994 Aubrey Jaffer (jaffer@jacal) + + * *.scm: Most missing copyright notices supplied. + +Sun Nov 27 23:57:41 1994 Aubrey Jaffer (jaffer@jacal) + + * rdms.scm (make-relational-system base): now checks field types + when table is opened. Domains table now has foreign-table field. + (for-each-row): ordered for-each function added. + * alistab.scm (ordered-for-each-key supported-key-type?): added. + +Thu Oct 27 12:20:41 1994 Tom Tromey + + * priorque.scm: Renamed everything to conform to coding standards + and updated docs. Changed names: heap-extract-max to + heap-extract-max!, heap-insert to heap-insert! and heap-size to + heap-length. + +Sat Nov 26 22:52:31 1994 Aubrey Jaffer (jaffer@jacal) + + * Template.scm *.init (identity): Now required; moved from + "comlist.scm". + + * alistab.scm (alist-table): Converted to representing rows as + lists. Non-row operations removed. + + * rdms.scm (make-relational-system base): Most individual column + operations removed. Only get and get* remain. Row operations + renamed. Row inserts and updates distinguished. + +Tue Nov 15 16:37:16 1994 Aubrey Jaffer (jaffer@jacal) + + * rdms.scm (make-relational-system base): Generalized database + system inspired by the Relational Model. + + * alistab.scm (alist-table): Base table implementation suitable + for small databases and testing rdms.scm. + +Tue Oct 25 22:36:01 1994 Aubrey Jaffer (jaffer@jacal) + + From: Tommy Thorn + * chez.init (scheme-implementation-version): fixed (changed to "?"). + (library-vicinity): The definition of library-vicinity used + getenv, which was defined later. + (slib:chez:quit): The definition of slib:chez:quit was illegal. + Fixed. + (chez:merge!): had a typo. + (defmacro:load): (require 'struct) didn't work, because defmacro:load + doesn't add suffix. Workaround: defmacro:load and macro:load is + the same as slib:load-source. + +Wed Oct 19 11:44:12 1994 Aubrey Jaffer (jaffer@jacal) + + * require.scm time.scm cltime.scm (difftime offset-time): added to + allow 'posix-time functions to work with a non-numeric type + returned by (current-time). + +Tue Aug 2 10:44:32 1994 Aubrey Jaffer (jaffer@jacal) + + * repl.scm (repl:top-level repl:repl): Multiple values at top + level now print nicely. + +Sun Jul 31 21:39:54 1994 Aubrey Jaffer (jaffer@jacal) + + * cltime.scm (get-decoded-time get-universal-time + decode-universal-time encode-universal-time): + Common-Lisp time conversion routines created. + + * time.scm (*timezone* tzset gmtime localtime mktime asctime ctime): + Posix time conversion routines created. + +Mon Jul 11 14:16:44 1994 Aubrey Jaffer (jaffer@jacal) + + * Template.scm mitscheme.init scheme2c.init t3.init (*features*): + trace added. + +Fri Jul 8 11:02:34 1994 Aubrey Jaffer (jaffer@jacal) + + * chap.scm ((chap:string did not include the expression and the + expression, instead it incorrectly included the + expression. (rf. R4RS, 4.2.4) + (hyg:tag-lambda): the body of a lambda expression should be + generated using hyg:tag-generic instead of hyg:tag-vanilla. This + allows expressions within lambda to behave hygienically. + (hyg:tag-let): extended to support `named let'. + +Sun Apr 10 00:22:04 1994 Aubrey Jaffer (jaffer@jacal) + + * README: INSTALLATION INSTRUCTIONS greatly improved. + * Template.scm *.init: Path configurations move to top of files + for easier installation. + + * FAQ: File of Frequently Asked Questions and answers added. + +Sat Apr 9 21:28:46 1994 Aubrey Jaffer (jaffer@jacal) + + * slib.texi (Vicinity): scheme-file-suffix removed. Use + slib:load or slib:load-source instead. + +Wed Apr 6 00:55:16 1994 Aubrey Jaffer (jaffer@jacal) + + * require.scm (slib:report): + (slib:report-version): + (slib:report-locations): added to display SLIB configuration + information. + +Mon Apr 4 08:48:37 1994 Aubrey Jaffer (jaffer@jacal) + + * Template.scm *.init (slib:exit): added. + +Fri Apr 1 14:36:46 1994 Aubrey Jaffer (jaffer@jacal) + + * Makefile (intro): Added idiot message for those who make. + Cleaned up and reorganized Makefile. + +Wed Mar 30 00:28:30 1994 Aubrey Jaffer (jaffer@jacal) + + * Template.scm *.init ((slib:eval-load evl)): created + to service all macro loads. + + From: whumeniu@datap.ca (Wade Humeniuk) + * recobj.scm yasyn.scm: added. These implement RECORDS and + YASOS using object.scm object system. + +Sun Mar 6 01:10:53 1994 Aubrey Jaffer (jaffer@jacal) + + From: barnett@armadillo.urich.edu (Lewis Barnett) + * gambit.init (implementation-vicinity library-vicinity): Relative + pathnames for Slib in MacGambit. + + From: lucier@math.purdue.edu (Brad Lucier) + * random.scm (random:random random:chunks/float): fixed off-by-one + and slop errors. + +Thu Mar 3 23:06:41 1994 Aubrey Jaffer (jaffer@jacal) + + From: lutzeb@cs.tu-berlin.de (Dirk Lutzebaeck) + * format.scm slib.texi: Format 3.0. + * format's configuration is rearranged to fit only into SLIB. All + implementation dependent configurations are done in the SLIB init files + * format's output routines rely on call-with-output-string now if + output to a string is desired + * The floating point formatting code (formatfl.scm) moved into + format.scm so that there is only one source code file; this + eliminates the configuration of the load path for the former + formatfl.scm and the unspecified scope of the load primitive + * floating point formatting doesn't use any floating point operation or + procedure except number->string now; all formatting is now based + solely on string, character and integer manipulations + * major rewrite of the floating point formatting code; use global + buffers now + * ~f,~e,~g, ~$ may use also number strings as an argument + * ~r, ~:r, ~@r, ~:@r roman numeral, and ordinal and cardinal + English number printing added (from dorai@cs.rice.edu) + * ~a has now a working `colinc' parameter + * ~t tabulate directive implemented + * ~/ gives a tabulator character now (was ~T in version < 2.4) + * ~& fresh line directive implemented + * ~@d, ~@b, ~@o and ~@x now has the CL meaning (plus sign printed) + automatic prefixing of radix representation is removed + * ~i prints complex numbers as ~f~@fi with passed parameters + * ~:c prints control characters like emacs (eg. ^C) and 8bit characters + as an octal number + * ~q gives information and copyright notice on this format implementation + ~:q gives format:version + * case type of symbol conversion can now be forced (see + format:symbol-case-conv in format.scm) + * case type of the representation of internal objects can now be + forced (see format:iobj-case-conv format.scm) + * format error messages are now printed on the current error port + if available by the implementation + * format now accepts a number as a destination port; the output + is then always directed to the current error port if available by + the implementation + * if format's destination is a string it is regarded as a format string now + and output is the current output port; this is a contribution to + Scheme->C to use format with the runtime system; the former semantics + to append tothe destination string is given up + * obj->string syntax change and speedup + * tested with scm4d, Elk 2.2, MIT Scheme 7.1, Scheme->C 01Nov91 + + +Wed Mar 2 13:16:37 1994 Aubrey Jaffer (jaffer@jacal) + + From: Matthias Blume + * vscm.init: added. + +Fri Feb 18 23:51:41 1994 Aubrey Jaffer (jaffer@jacal) + + From: jjb@isye.gatech.edu (John Bartholdi) + * macscheme.init: added. + +Thu Feb 17 01:19:47 1994 Aubrey Jaffer (jaffer@jacal) + + * ppfile.scm ((pprint-filter-file inport filter outport)): added. + Useful for pre-expanding macros. Preserves top-level comments. + +Wed Feb 16 12:44:34 1994 Aubrey Jaffer (jaffer@jacal) + + From: dorai@cs.rice.edu (Dorai Sitaram) + * mbe.scm: Macro by Example define-syntax using defmacro. + +Tue Feb 15 17:18:56 1994 Aubrey Jaffer (jaffer@jacal) + + From: whumeniu@datap.ca (Wade Humeniuk) + * object.scm: Macroless Object System + +Mon Feb 14 00:48:18 1994 Aubrey Jaffer (jaffer@jacal) + + * defmacex.scm (defmacro:expand*): replaces "defmacro.scm". Other + defmacro functions now supported in all implementations. + +Sun Feb 13 12:38:39 1994 Aubrey Jaffer (jaffer@jacal) + + * defmacro.scm (defmacro:macroexpand*): now expands quasiquotes + correctly. + +Sat Feb 12 21:23:56 1994 Aubrey Jaffer (jaffer@jacal) + + * hashtab.scm ((predicate->hash pred)): moved from hash.scm. + +Tue Feb 8 01:07:00 1994 Aubrey Jaffer (jaffer@jacal) + + * Template.scm *.init (slib:load-source slib:load-compiled + slib:load): support for loading compiled modules added. + Dependence on SCHEME-FILE-SUFFIX removed. + + * require.scm (require:require): Added support for 'source and + 'compiled features. + +Sat Feb 5 00:19:38 1994 Aubrey Jaffer (jaffer@jacal) + + * stdio.scm ((stdio:sprintf)): Now truncates printing if you run + out of string. + +Fri Feb 4 00:54:14 1994 Aubrey Jaffer (jaffer@jacal) + + From: pk@kaulushaikara.cs.tut.fi (Kellom{ki Pertti) + * (psd/primitives.scm): Here is a patch removing some problems + with psd-1.1, especially when used with Scheme 48. Thanks to + Jonathan Rees for poiting them out. The patch fixes two problems: + references to an unused variable *psd-previous-line*, and the + correct number of arguments to write-char. + +Fri Jan 14 00:37:19 1994 Aubrey Jaffer (jaffer@jacal) + + * require.scm (require:require): Now supports (feature . + argument-list) associations. + +Sat Nov 13 22:07:54 1993 (jaffer at jacal) + + * slib.info (Structures): added. Bug - struct.scm and + structure.scm do not implement the same macros. + +Mon Nov 1 22:17:01 1993 (jaffer at jacal) + + * array.scm (array-dimensions array-rank array-in-bounds?): + added. + +Sat Oct 9 11:54:54 1993 (jaffer at jacal) + + * require.scm (*catalog* portable-scheme-debugger): support added + for psd subdirectory. + +Tue Sep 21 11:48:26 1993 Aubrey Jaffer (jaffer at wbtree) + + * Makefile (lineio.scm rbtree.scm rbtest.scm scmacro.scm + sc4sc3.scm scaespp.scm scaglob.scm scainit.scm scamacr.scm + scaoutp.scm strcase.scm): hyphens removed from names. + +Mon Sep 20 00:57:29 1993 (jaffer at jacal) + + * arraymap.scm (array-map! array-for-each array-indexes): added. + +Sun Sep 19 19:20:49 1993 (jaffer at jacal) + + * require.scm (require:feature->path require:require *catalog*): + associations of the form (symbol1 . symbol2) in *catalog* look up + symbol2 whenever symbol1 is specified. + +Mon Sep 13 22:12:00 1993 (jaffer at jacal) + + From: sperber@provence.informatik.uni-tuebingen.de (Michael Sperber) + * elk.init: updated to ELK version 2.1. + +Sat Sep 11 21:17:45 1993 (jaffer at jacal) + + * hashtab.scm (hash-for-each): fixed and documented (also + documented alist.scm). + +Fri Sep 10 15:57:50 1993 (jaffer at jacal) + + * getopt.scm (getopt *optind* *optarg*): added. + +Tue Sep 7 23:57:40 1993 (jaffer at jacal) + + * slib1d3 released. + * comlist.scm: prefixed all functions with "comlist:". + +Tue Aug 31 23:59:28 1993 (jaffer at jacal) + + * Template.scm *.init (output-port-height): added. + +Wed May 26 00:00:51 1993 Aubrey Jaffer (jaffer at camelot) + + * hashtab.scm (hash-map hash-for-each): added. + * alist.scm (alist-map alist-for-each): added. + +Tue May 25 22:49:01 1993 Aubrey Jaffer (jaffer at camelot) + + * comlist.scm (delete delete-if atom): renamed as in common lisp. + * comlist.scm (delete-if-not): added. + * tree.scm: moved tree functions out of comlist.scm + +Mon May 24 10:28:22 1993 Aubrey Jaffer (jaffer at camelot) + + From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) + * modular.scm: improvements and fixed bug in modular:expt. + +Fri May 14 01:26:44 1993 Aubrey Jaffer (jaffer at camelot) + + * slib1d2 released. + + From: Dave Love + * comlist.scm: added some tree functions. + * yasos.scm collect.scm: fixed name conflicts and documentation. + +Tue May 11 01:22:40 1993 Aubrey Jaffer (jaffer at camelot) + + * eval.scm: removed because all *.init files support it. + + * hash.scm: made all hash functions case-insensitive. Equal + inexact and exact numbers now hash to the same code. + + From: eigenstr@falstaff.cs.rose-hulman.edu: + * slib.texi: revised. + +Sun May 9 01:43:11 1993 Aubrey Jaffer (jaffer at camelot) + + From: kend@newton.apple.com (Ken Dickey) + * macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm: Macros no + longer expand builtin Scheme forms. + + From: William Clinger + * macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm: Macros that + work added. + +Sat May 1 23:55:42 1993 Aubrey Jaffer (jaffer at montreux) + + * random.scm (random:random): sped up for exact arguments. + +Wed Apr 28 00:24:36 1993 Aubrey Jaffer (jaffer at camelot) + + From: lutzeb@flp.cs.tu-berlin.de (Dirk Lutzebaeck) + * format.scm formatfl.scm formatst.scm slib.texi: Format 2.3. + * implemented floating point support ~F,~E,~G,~$ + * automatic detection if the scheme interpreter support flonums. + * the representation of internal objects can be selected to be + #<...> or #[...] or other forms + * new/redefintion of configuration variables format:abort, + format:floats, format:formatfl-path, format:iobj-pref, format:iobj-post + * added string-index + * added MIT Scheme 7.1 custom types + * for efficiencies reasons the error continuation is only used if + format:abort is not available + * improved error presentation and error handling + * tested with scm4b/c, Elk 2.0, MIT Scheme 7.1, Scheme->C 01Nov91, + UMB Scheme 2.5/2.10 + +Sun Apr 25 22:40:45 1993 Aubrey Jaffer (jaffer at camelot) + + From: Dave Love + * scheme2c.init: corrections and portability improvements. + * yasos.scm collect.scm: +These correct the scheme2c.init and a couple of other things as well as +hiding some non-exported definitions and removing an example from +collect.scm to the manual. + +Sat Apr 3 00:48:13 1993 Aubrey Jaffer (jaffer at camelot) + + From: eigenstr@cs.rose-hulman.edu (Todd R. Eigenschink) + * slib.texi: created. + +Thu Mar 25 01:47:38 1993 Aubrey Jaffer (jaffer at camelot) + + From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) + * sca-init.scm sca-glob.scm sca-macr.scm sca-outp.scm + sca-expp.scm: syntax-case macros added. + +Wed Mar 24 23:12:49 1993 Aubrey Jaffer (jaffer at camelot) + + * comlist.scm (some every notany notevery): Now accept multiple + arguments. NOTANY added. + +Wed Mar 3 01:19:11 1993 Aubrey Jaffer (jaffer at camelot) + + From: "Dan Friedman" + * struct.scm structst.scm: added. + +Tue Mar 2 00:28:00 1993 Aubrey Jaffer (jaffer at camelot) + + * obj2str (object->string): now handles symbols and number without + going to string-port. + +Sun Feb 28 22:22:50 1993 Aubrey Jaffer (jaffer at camelot) + + * all files with Jaffer copyright: Now have explicit conditions + for use and copying. + +Fri Feb 26 00:29:18 1993 Aubrey Jaffer (jaffer at camelot) + + * obj2str: redefined in terms of string ports. + + * pp2str: eliminated. + +Mon Feb 22 17:21:21 1993 Aubrey Jaffer (jaffer at camelot) + + From: dorai@cs.rice.edu (Dorai Sitaram) + * strport.scm: string ports. + + From: Alan@LCS.MIT.EDU (Alan Bawden) + * array.scm: functions which implement arrays. + +Wed Feb 17 00:18:57 1993 Aubrey Jaffer (jaffer at camelot) + + * repl.scm: split off from sc-macro.scm. + + * eval.scm *.init Template.scm (eval!): eliminated. + + From: dorai@cs.rice.edu (Dorai Sitaram) + * defmacro.scm: added. Chez, elk, mitscheme, scheme2c, and scm + support. + +Tue Feb 16 00:23:07 1993 Aubrey Jaffer (jaffer at camelot) + + * require.doc (output-port-width current-error-port tmpnam + file-exists? delete-file force-output char-code-limit + most-positive-fixnum slib:tab slib:form-feed error):descriptions + added. + + * *.init (tmpnam): now supported by all. + + From: dorai@cs.rice.edu (Dorai Sitaram) + * chez.init elk.init mitscheme.init scheme2c.init (defmacro macro? + macro-expand): added. + +Mon Feb 15 00:51:22 1993 Aubrey Jaffer (jaffer at camelot) + + * Template.scm *.init (file-exists? delete-file): now defined for + all implementations. + +Sat Feb 13 23:40:22 1993 Aubrey Jaffer (jaffer at camelot) + + * chez.init (slib:error): output now directed to + (current-error-port). + +Thu Feb 11 01:23:25 1993 Aubrey Jaffer (jaffer at camelot) + + * withfile.scm (with-input-from-file with-output-from-file): now + close file on thunk return. + + * *.init (current-error-port): added. + +Wed Feb 10 17:57:15 1993 Aubrey Jaffer (jaffer at camelot) + + * mitscheme.init (values dynamic-wind): added to *features*. + + From: mafm@cs.uwa.edu.au (Matthew MCDONALD) + * mitcomp.pat: added patch file of definitions for compiling SLIB + with MitScheme. + +Tue Feb 9 10:49:12 1993 Aubrey Jaffer (jaffer at camelot) + + From: jt@linus.mitre.org (F. Javier Thayer) + * t3.init: additions and corrections. + +Mon Feb 8 20:27:18 1993 Aubrey Jaffer (jaffer at camelot) + + From: dorai@cs.rice.edu (Dorai Sitaram) + * chez.init: added. + +Wed Feb 3 23:33:49 1993 Aubrey Jaffer (jaffer at camelot) + + * sc-macro.scm (macro:repl): now prints error message for errors. + +Mon Feb 1 22:22:17 1993 Aubrey Jaffer (jaffer at camelot) + + * logical.scm (logor): changed to logior to be compatible with + common Lisp. + +Fri Jan 29 17:15:03 1993 Aubrey Jaffer (jaffer at camelot) + + From: jt@linus.mitre.org (F. Javier Thayer) + * t3.init: modified so it passes most of SCM/test.scm. + +Sun Jan 24 00:18:13 1993 Aubrey Jaffer (jaffer at camelot) + + * comlist.scm (intersection): added. + +Wed Jan 13 19:01:11 1993 Aubrey Jaffer (jaffer at camelot) + + * debug.scm: (debug:qp): needed to shadow quotient. + +Sat Jan 9 13:44:44 1993 Aubrey Jaffer (jaffer at camelot) + + * rb-tree.scm: changed use of '() and NULL? to #f and NOT. + + * rb-tree.scm (rb-insert! rb-delete!) added ! to names. + +Fri Jan 8 01:17:16 1993 Aubrey Jaffer (jaffer at camelot) + + * rb-tree.doc: added. + + From: pgs@ai.mit.edu (Patrick Sobalvarro) + * rb-tree.scm rbt-test.scm: code for red-black trees added. + +Tue Jan 5 14:57:02 1993 Aubrey Jaffer (jaffer at camelot) + + From: lutzeb@cs.tu-berlin.de (Dirk Lutzebaeck) + * format.scm formatst.scm format.doc: version 2.2 + * corrected truncation for fixed fields by negative field parameters + inserted a '<' or a '>' when field length was equal to object string + length + * changed #[...] outputs to #<...> outputs to be conform to SCM's + display and write functions + * changed #[non-printable-object] output to # + * ~:s and ~:a print #<...> messages in strings "#<...>" so that the + output can always be processed by (read) + * changed implementation dependent part: to configure for various scheme + systems define the variable format:scheme-system + * format:version is a variable returning the format version in a string + * format:custom-types allows to use scheme system dependent predicates + to identify the type of a scheme object and its proper textual + representation + * tested with scm4a14, Elk 2.0 + +Tue Dec 22 17:36:23 1992 Aubrey Jaffer (jaffer at camelot) + + * Template.scm *.init (char-code-limit): added. + + * debug.scm (qp): qp-string had bug when printing short strings + when room was less than 3. + + * random.scm (random:size-int): now takes most-positive-fixnum + into account. + +Wed Nov 18 22:59:34 1992 Aubrey Jaffer (jaffer at camelot) + + From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) + * randinex.scm (random:normal-vector! random:normal + random:solid-sphere random:hollow-sphere): new versions fix bug. + +Tue Nov 17 14:00:15 1992 Aubrey Jaffer (jaffer at Ivan) + + * str-case.scm (string-upcase string-downcase string-capitalize + string-upcase! string-downcase! string-capitalize!): moved from + format.scm. + +Fri Nov 6 01:09:38 1992 Aubrey Jaffer (jaffer at Ivan) + + * require.scm (require): uses base:load instead of load. + + * sc-macro.scm (macro:repl): now uses dynamic-wind. + +Mon Oct 26 13:21:04 1992 Aubrey Jaffer (jaffer at Ivan) + + * comlist.scm (nthcdr last) added. + +Sun Oct 25 01:50:07 1992 Aubrey Jaffer (jaffer at Ivan) + + * line-io.scm: created + +Mon Oct 19 12:53:01 1992 Aubrey Jaffer (jaffer at camelot) + + From: dorai@cs.rice.edu + * fluidlet.scm: FLUID-LET that works. + +Thu Oct 8 22:17:01 1992 Aubrey Jaffer (jaffer at camelot) + + From: Robert Goldman + * mitscheme.init: improvements. + +Sun Oct 4 11:37:57 1992 Aubrey Jaffer (jaffer at camelot) + + * values.scm values.doc: Documentation rewritten and combined + into values.scm + +Thu Oct 1 23:29:43 1992 Aubrey Jaffer (jaffer at Ivan) + + * sc-macro.scm sc-macro.doc: documentation improved and moved into + sc-macro.doc. + +Mon Sep 21 12:07:13 1992 Aubrey Jaffer (jaffer at Ivan) + + * sc-macro.scm (macro:load): now sets and restores *load-pathname*. + + * eval.scm (slib:eval!): (program-vicinity) now correct during + evaluation. + + * Template.scm, *.init: i/o-redirection changed to with-file. + *features* documentation changed. + + From: Stephen J Bevan + * t3.init: new. Fixes problems with require, substring, and + <,>,<=,>= with more than 2 arguments. + +Fri Sep 18 00:10:57 1992 Aubrey Jaffer (jaffer at Ivan) + + From andrew@astro.psu.edu Wed Sep 16 17:58:21 1992 + * dynamic.scm: added. + + From raible@nas.nasa.gov Thu Sep 17 22:28:25 1992 + * fluidlet.scm: added. + +Sun Sep 13 23:08:46 1992 Aubrey Jaffer (jaffer at Ivan) + + * sc-macro.scm (macro:repl): moved (require 'debug) into syntax-error. + + * dynwind.scm, withfile.scm, trnscrpt.scm: created. + + From kend@data.rain.com Sun Sep 13 21:26:59 1992 + * collect.scm: created. + * oop.scm => yasos.scm: updated. + * oop.doc: removed. + + From: Stephen J. Bevan 19920912 + * elk.init: created + +Tue Jul 14 11:42:57 1992 Aubrey Jaffer (jaffer at Ivan) + + * tek41.scm tek40.scm: added. + +Tue Jul 7 00:55:58 1992 Aubrey Jaffer (jaffer at Ivan) + + * record.scm record.doc (record-sub-predicate): added. + + * sc-macro.scm (macro:repl): syntax-errors now return into + macro:repl. + + * debug.scm (qp): removed (newline). Added qpn (qp with newline). + +Sun Jun 14 22:57:32 1992 Aubrey Jaffer (jaffer at Ivan) + + * slib1b8 released. + +Sat Jun 13 17:01:41 1992 Aubrey Jaffer (jaffer at Ivan) + + * alist.scm ppfile.scm: added. + + * hash.scm hashtab.scm scheme48.init: added. + + * sc-macro.scm (macro:repl): created. macro:load now uses + eval:eval!. + + * eval.scm (eval:eval!) created and eval done in terms of it. + + * prime.scm (prime:prime?) fixed misplaced parenthesis. + +Wed May 27 16:13:17 1992 Aubrey Jaffer (jaffer at Ivan) + + From: "Chris Hanson" + * synrul.scm (generate-match): fixed for CASE syntax. + +Wed May 20 00:25:40 1992 Aubrey Jaffer (jaffer at Ivan) + + * slib1b6 released. + + * Template.scm gambit.init mitscheme.init scheme2c.init: + rearranged *features*. + +Tue May 19 22:51:28 1992 Aubrey Jaffer (jaffer at Ivan) + + * scmactst.scm: test cases fixed. + + From: "Chris Hanson" + * r4syn.scm (make-r4rs-primitive-macrology): TRANSFORMER added + back in. + + * require.scm (load): load now passes through additional + arguments to *old-load*. + +Mon May 18 00:59:36 1992 Aubrey Jaffer (jaffer at Ivan) + + * mulapply.scm (apply): written. + + * record.scm record.doc (make-record-sub-type): added. + +Fri May 8 17:55:14 1992 Aubrey Jaffer (jaffer at Ivan) + + * process.scm: created, but not finished. + + From: hugh@ear.mit.edu (Hugh Secker-Walker) + * comlist.scm (nreverse make-list): non-recursive versions added. + + * sc2.scm (1+ -1+): versions which capture +. + + * mularg.scm (- /): created. + +Wed Apr 8 00:05:30 1992 Aubrey Jaffer (jaffer at Ivan) + + * require.scm sc-macro.scm (catalog): Now uses macro:load if + 'macro is part of catalog entry. + + From: Andrew Wilcox (awilcox@astro.psu.edu) + * queue.scm: created. + +Sun Mar 15 12:23:06 1992 Aubrey Jaffer (jaffer at Ivan) + + * comlist.scm (notevery): fixed. Now (not (every ..)). + + * eval.scm (eval:eval): renamed to slib:eval. + + * record.scm: replaced with version from From: david carlton + . I changed updater => modifier, put + record-predicate into the rtd, and bummed code mercilessly. + + From: plogan@std.mentor.com (Patrick Logan) + * sc3.scm (last-pair): changed from testing null? to pair?. diff --git a/FAQ b/FAQ new file mode 100644 index 0000000..3b4d812 --- /dev/null +++ b/FAQ @@ -0,0 +1,216 @@ +FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib2a6). +Written by Aubrey Jaffer (jaffer@ai.mit.edu). + + INTRODUCTION AND GENERAL INFORMATION + +[] What is SLIB? + +SLIB is a portable scheme library meant to provide compatibiliy and +utility functions for all standard scheme implementations. + +[] What is Scheme? + +Scheme is a programming language in the Lisp family. + +[] Which implementations has SLIB been ported to? + +SLIB is currently supported by Chez, ELK 2.1, GAMBIT, MacScheme, +MITScheme, scheme->C, Scheme48, T3.1, SCM and VSCM + +[] How can I get SLIB? + +SLIB is available via ftp from: + ftp-swiss.ai.mit.edu:pub/scm/slib2a6.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/slib2a6.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2a6.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2a6.tar.gz + +SLIB is also included with SCM floppy disks. + +[] How do I install SLIB? + +Read the INSTALLATION INSTRUCTIONS in "slib/README". + +[] What are slib.texi and slib.info? + +"slib.texi" is the `texinfo' format documentation for SLIB. +"slib.info" is produced from "slib.texi" by either Gnu Emacs or the +program `makeinfo'. "slib.info" can be viewed using either Gnu Emacs +or `info' or a text editor. + +Programs for printing and viewing TexInfo documentation (which SLIB +has) come with GNU Emacs or can be obtained via ftp from: +prep.ai.mit.edu:pub/gnu/texinfo-3.1.tar.gz + +[] How often is SLIB released? + +SLIB was released 9 times in 1993. + +[] What is the latest version? + +The version as of this writing is slib2a6. + +[] What version am I using? + +The Version is in the first line of the files slib/FAQ, slib/ANNOUNCE, +and slib/README. If you have Scheme and SLIB running, type +(slib:report-version) + + SLIB INSTALLATION PROBLEMS + +[] When I load an SLIB initialization file for my Scheme + implementation, I get ERROR: Couldn't find "require.scm" + +Did you remember to set either the environment variable +SCHEME_LIBRARY_PATH or the library-vicinity in your initialization +file to the correct location? Make sure if you set only the +environment variable SCHEME_LIBRARY_PATH that your implementation +supports getenv. + +[] When I load an SLIB initialization file for my Scheme + implementation, I get ERROR: Couldn't find + "/usr/local/lib/slibrequire.scm" + +Notice that it is looking for "slibrequire.scm" rather than +"slib/require.scm". You need to put a trailing slash on either the +environment variable SCHEME_LIBRARY_PATH or in the library-vicinity in +your initialization file. + +[] SLIB used to work, but now I get ERROR: Couldn't find + "slib/require.scm". What happened? + +You changed directories and now the relative pathname +"slib/require.scm" no longer refers to the same directory. The +environment variable SCHEME_LIBRARY_PATH and library-vicinity in your +initialization file should be absolute pathnames. + +[] When I type (require 'macro) I get "ERROR: unbound variable: + require". + +You need to arrange to have your Scheme implementation load the +appropriate SLIB initialization file ("foo.init") before using SLIB. +If your implementation loads an initialization file on startup, you +can have it load the SLIB initialization file automatically. For +example (load "/usr/local/lib/slib/foo.init"). + +[] Why do I get a string-ref (or other) error when I try to load + or use SLIB. + +Check that the version of the Scheme implementation you are using +matches the version for which the SLIB initialization file was +written. There are some notes in the SLIB initialization files about +earlier versions. You may need to get a more recent version of your +Scheme implementation. + + USING SLIB PROCEDURES + +[] I installed SLIB. When I type (random 5) I get "ERROR: + unbound variable: random". Doesn't SLIB have a `random' + function? + +Before you can use most SLIB functions, the associated module needs to +be loaded. You do this by typing the line that appears at the top of +the page in slib.info (or slib.texi) where the function is documented. +In the case of random, the line is (require 'random). + +[] Why doesn't SLIB just load all the functions so I don't have + to type require statements? + +SLIB currently has more than 1 Megabyte of Scheme source code. Many +scheme implementations take unacceptably long to load 1 Megabyte of +source; some implementations cannot allocate enough storage. If you +use a package often, you can put the require statement in your Scheme +initialization file. Consult the manual for your Scheme +implementation to find out the initialization file's name. + +`Autoloads' will work with many Scheme implementations. You could put +the following in your initialization file: + (define (random . args) (require 'random) (apply random args)) + +I find that I only type require statements at top level when +debugging. I put require statements in my Scheme files so that the +appropriate modules are loaded automatically. + +[] Why does SLIB have PRINTF when it already has the more + powerful (CommonLisp) FORMAT? + +CommonLisp FORMAT does not support essential features which PRINTF +does. For instance, how do you format a signed 0 extended number? + + (format t "~8,'0,X~%" -3) ==> 000000-3 + +But printf gets it right: + + (printf "%08x\n" -3) ==> -0000003 + +How can one trunctate a non-numeric field using FORMAT? This feature +is essential for printing reports. The first 20 letters of a name is +sufficient to identify it. But if that name doesn't get trucated to +the desired length it can displace other fields off the page. Once +again, printf gets it right: + + (printf "%.20s\n" "the quick brown fox jumped over the lazy dog") + ==> the quick brown fox + +FORMAT also lacks directives for formatting date and time. printf +does not handle these directly, but a related function strftime does. + +[] Why doesn't SLIB:ERROR call FORMAT? + +Format does not provide a method to truncate fields. When an error +message contains non-terminating or large expressions, the essential +information of the message may be lost in the ensuing deluge. + +FORMAT as currently written in SLIB is not reentrant. Until this is +fixed exception handlers and errors which might occur while using +FORMAT cannot use it. + + MACROS + +[] Why are there so many macro implementations in SLIB? + +The R4RS committee specified only the high level pattern language in +the Revised^4 Report on Scheme and left to the free marketplace of +ideas the details of the low-level facility. Each macro package has a +different low-level facility. The low-level facilities are sometimes +needed because the high level pattern language is insufficiently +powerful to accomplish tasks macros are often written to do. + +[] Why are there both R4RS macros and Common-Lisp style defmacros + in SLIB? + +Most current Scheme implementations predate the adoption of the R4RS +macro specification. It turns out that all of the implementations +can support defmacro natively. + +[] I did (LOAD "slib/yasos.scm"). The error I get is "variable + define-syntax is undefined". + +The way to load the struct macro package is (REQUIRE 'YASOS). + +[] I did (REQUIRE 'YASOS). Now when I type (DEFINE-PREDICATE + CELL?) The error I get is "variable define-predicate is + undefined". + +If like most implementations, your Scheme does not natively support +R4RS macros you will need to install a macro-capable read-eval-print +loop. This is done by: + (require 'macro) ;already done if you did (require 'yasos) + (require 'repl) + (repl:top-level macro:eval) + +This is also true for Schemes which don't support DEFMACRO. The lines +in this case are: + (require 'repl) + (repl:top-level defmacro:eval) + +[] I always use R4RS macros. How can I avoid having to type + require statements every time I start Scheme? + +As is explained in the Repl entry in slib.info (or slib.texi): + + To have your top level loop always use macros, add any interrupt + catching lines and the following lines to your Scheme init file: + (require 'macro) + (require 'repl) + (repl:top-level macro:eval) diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..a2b8de7 --- /dev/null +++ b/Makefile @@ -0,0 +1,229 @@ +# Makefile for Scheme Library +# Copyright (C) 1991, 1992, 1993, 1994, 1995 Aubrey Jaffer. + +SHELL = /bin/sh +intro: + @echo + @echo "Welcome to SLIB. Read \"README\" and \"slib.info\" (or" + @echo "\"slib.texi\") to learn how to install and use SLIB." + @echo + @echo + -make slib.info + +srcdir=$(HOME)/slib/ +dvidir=../dvi/ +dvi: $(dvidir)slib.dvi +$(dvidir)slib.dvi: $(srcdir)slib.texi $(dvidir)slib.fn +# cd $(dvidir);texi2dvi $(srcdir)slib.texi + -(cd $(dvidir);texindex slib.??) + cd $(dvidir);tex $(srcdir)slib.texi +$(dvidir)slib.fn: + cd $(dvidir);tex $(srcdir)slib.texi +xdvi: $(dvidir)slib.dvi + xdvi $(dvidir)slib.dvi + +prefix = /usr/local +exec_prefix = $(prefix) +bindir = $(exec_prefix)/bin +libdir = $(exec_prefix)/lib +infodir = $(exec_prefix)/info +RUNNABLE = scheme48 +LIB = $(libdir)/$(RUNNABLE) +VM = scheme48vm +IMAGE = slib.image + +slib48: + (echo ,load `pwd`/scheme48.init; \ + echo "(define *args* '())"; \ + echo "(define (program-arguments) (cons \"$(VM)\" *args*))"; \ + echo ,dump $(LIB)/$(IMAGE); \ + echo ,exit) | scheme48 + (echo '#!/bin/sh'; \ + echo exec '$(LIB)/$(VM)' -i '$(LIB)/$(IMAGE)' \"\$$\@\") \ + > $(bindir)/slib48 + chmod +x $(bindir)/slib48 + +info: $(infodir)/slib.info + -make schelog-info +$(infodir)/slib.info: slib.texi + makeinfo slib.texi -o $(infodir)/slib.info + +infoz: $(infodir)/slib.info.gz + -make schelog-infoz +$(infodir)/slib.info.gz: $(infodir)/slib.info + -rm $(infodir)/slib.info*.gz + gzip $(infodir)/slib.info* + +#### Stuff for maintaining SLIB below #### + +VERSION = 2a6 +ver = $(VERSION) +ffiles = printf.scm format.scm genwrite.scm obj2str.scm pp.scm \ + ppfile.scm strcase.scm debug.scm trace.scm lineio.scm \ + strport.scm scanf.scm chap.scm qp.scm break.scm stdio.scm \ + strsrch.scm +lfiles = sort.scm comlist.scm tree.scm logical.scm random.scm tsort.scm +revfiles = sc4opt.scm sc4sc3.scm sc2.scm mularg.scm mulapply.scm \ + trnscrpt.scm withfile.scm dynwind.scm promise.scm values.scm +afiles = ratize.scm randinex.scm modular.scm primes.scm factor.scm \ + charplot.scm time.scm cltime.scm root.scm +bfiles = collect.scm fluidlet.scm struct.scm \ + object.scm recobj.scm yasyn.scm +# yasos.scm +scfiles = r4rsyn.scm scmacro.scm synclo.scm synrul.scm synchk.scm \ + repl.scm macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm +scafiles = scainit.scm scaglob.scm scamacr.scm scaoutp.scm scaexpp.scm \ + structure.scm +dfiles = defmacex.scm mbe.scm +efiles = record.scm dynamic.scm queue.scm process.scm \ + priorque.scm hash.scm hashtab.scm alist.scm \ + wttree.scm wttest.scm array.scm arraymap.scm \ + sierpinski.scm soundex.scm +rfiles = rdms.scm alistab.scm dbutil.scm paramlst.scm report.scm \ + batch.scm makcrc.scm dbrowse.scm comparse.scm getopt.scm +gfiles = tek40.scm tek41.scm +docfiles = ANNOUNCE README FAQ ChangeLog slib.texi +mfiles = Makefile require.scm Template.scm +ifiles = chez.init elk.init macscheme.init \ + mitscheme.init scheme2c.init scheme48.init gambit.init t3.init \ + vscm.init mitcomp.pat syncase.sh +tfiles = plottest.scm formatst.scm macrotst.scm scmactst.scm \ + dwindtst.scm structst.scm +sfiles = $(ffiles) $(lfiles) $(revfiles) $(afiles) $(scfiles) $(efiles) \ + $(rfiles) $(gfiles) $(scafiles) $(dfiles) +allfiles = $(docfiles) $(mfiles) $(ifiles) $(sfiles) $(tfiles) $(bfiles) + +makedev = make -f $(HOME)/makefile.dev +CHPAT=$(HOME)/bin/chpat +dest = $(HOME)/dist/ +temp/slib: $(allfiles) + -rm -rf temp + mkdir temp + mkdir temp/slib + ln $(allfiles) temp/slib + +infotemp/slib: slib.info + -rm -rf infotemp + mkdir infotemp + mkdir infotemp/slib + ln slib.info slib.info-* infotemp/slib + +distinfo: $(dest)slib.info.tar.gz +$(dest)slib.info.tar.gz: infotemp/slib + $(makedev) TEMP=infotemp/ DEST=$(dest) PROD=slib ver=.info tar.gz + rm -rf infotemp + +dist: $(dest)slib$(VERSION).tar.gz +$(dest)slib$(VERSION).tar.gz: temp/slib + $(makedev) DEST=$(dest) PROD=slib ver=$(VERSION) tar.gz +shar: slib.shar +slib.shar: temp/slib + $(makedev) PROD=slib shar +dclshar: slib.com +com: slib.com +slib.com: temp/slib + $(makedev) PROD=slib com +zip: slib.zip +slib.zip: temp/slib + $(makedev) PROD=slib zip +distzip: slib$(VERSION).zip +slib$(VERSION).zip: temp/slib + $(makedev) DEST=$(dest) PROD=slib ver=$(VERSION) zip + mv $(dest)slib$(VERSION).zip /c/scm/dist/ +pubzip: temp/slib + $(makedev) DEST=$(HOME)/pub/ PROD=slib zip + +diffs: pubdiffs +pubdiffs: temp/slib + $(makedev) DEST=$(HOME)/pub/ PROD=slib pubdiffs +distdiffs: temp/slib + $(makedev) DEST=$(dest) PROD=slib ver=$(ver) distdiffs +announcediffs: temp/slib + $(makedev) DEST=$(dest) PROD=slib ver=2a1 announcediffs + +psdfiles=COPYING.psd README.psd cmuscheme.el comint.el instrum.scm pexpr.scm \ + primitives.scm psd-slib.scm psd.el read.scm runtime.scm version.scm +psdocfiles=article.bbl article.tex manual.bbl manual.tex quick-intro.tex + +psdtemp/slib: + -rm -rf psdtemp + mkdir psdtemp + mkdir psdtemp/slib + mkdir psdtemp/slib/psd + cd psd; ln $(psdfiles) ../psdtemp/slib/psd + mkdir psdtemp/slib/psd/doc + cd psd/doc; ln $(psdocfiles) ../../psdtemp/slib/psd/doc + +psdist: $(dest)slib-psd.tar.gz +$(dest)slib-psd.tar.gz: psdtemp/slib + $(makedev) DEST=$(dest) PROD=slib ver=-psd tar.gz TEMP=psdtemp/ + +schelogfiles = copying schelog.doc schelog.scm schelog.texi +schelogexamples = bible.scm england2.scm holland.scm mapcol.scm \ + schelogt.scm england.scm games.scm houses.scm puzzle.scm \ + toys.scm + +schelogtemp/slib: + -rm -rf schelogtemp + mkdir schelogtemp + mkdir schelogtemp/slib + mkdir schelogtemp/slib/schelog + cd schelog; ln $(schelogfiles) ../schelogtemp/slib/schelog + mkdir schelogtemp/slib/schelog/examples + cd schelog/examples; ln $(schelogexamples) \ + ../../schelogtemp/slib/schelog/examples + +schelogdist: schelog-dist +schelog-dist: $(dest)slib-schelog.tar.gz +$(dest)slib-schelog.tar.gz: schelogtemp/slib + $(makedev) DEST=$(dest) PROD=slib ver=-schelog tar.gz TEMP=schelogtemp/ + +schelog-info: $(infodir)/schelog.info +$(infodir)/schelog.info: schelog/schelog.texi + makeinfo schelog/schelog.texi -o $(infodir)/schelog.info + +schelog-infoz: $(infodir)/schelog.info.gz +$(infodir)/schelog.info.gz: $(infodir)/schelog.info + -rm $(infodir)/schelog.info*.gz + gzip $(infodir)/schelog.info* + +schelog.dvi: $(dvidir)schelog.dvi +$(dvidir)schelog.dvi: $(srcdir)schelog/schelog.texi $(dvidir)schelog.fn +# cd $(dvidir);texi2dvi $(srcdir)schelog/schelog.texi + -(cd $(dvidir);texindex schelog.??) + cd $(dvidir);tex $(srcdir)schelog/schelog.texi +$(dvidir)schelog.fn: + cd $(dvidir);tex $(srcdir)schelog/schelog.texi +schelog-xdvi: $(dvidir)schelog.dvi + xdvi $(dvidir)schelog.dvi + +new: + $(CHPAT) slib$(VERSION) slib$(ver) ANNOUNCE FAQ ../scm/ANNOUNCE \ + ../jacal/ANNOUNCE ../wb/README ../wb/ANNOUNCE \ + /c/scm/dist/install.bat /c/scm/dist/makefile \ + ../public_html/README.html ../dist/README \ + ../public_html/SLIB.html ../public_html/JACAL.html \ + ../public_html/SCM.html ../public_html/Hobbit.html \ + /c/scm/dist/mkdisk.bat \ + ../scm/README ../scm/scm.texi + $(CHPAT) $(VERSION) $(ver) README slib.texi require.scm Makefile + +tagfiles = slib.texi $(mfiles) $(sfiles) $(bfiles) $(tfiles) +# README and $(ifiles) cause semgentation faults in ETAGS for Emacs version 19. +tags: $(tagfiles) + etags $(tagfiles) +test: $(sfiles) + scheme Template.scm $(sfiles) +rights: + scm -ladmin -e"(admin:check-all)" $(sfiles) $(tfiles) \ + $(bfiles) $(ifiles) +clean: + -rm -f *~ *.bak *.orig *.rej core a.out *.o \#* + -rm -rf *temp +distclean: realclean +realclean: + -rm -f *~ *.bak *.orig *.rej TAGS core a.out *.o \#* + -rm -f slib.info* slib.?? slib.??? + -rm -rf *temp +realempty: temp/slib + -rm -f $(allfiles) diff --git a/README b/README new file mode 100644 index 0000000..35f7448 --- /dev/null +++ b/README @@ -0,0 +1,220 @@ +This directory contains the distribution of Scheme Library slib2a3. +Slib conforms to Revised^4 Report on the Algorithmic Language Scheme +and the IEEE P1178 specification. Slib supports Unix and similar +systems, VMS, and MS-DOS. + +The maintainer can be reached at jaffer@ai.mit.edu. + + MANIFEST + + `README' is this file. It contains a MANIFEST, INSTALLATION + INSTRUCTIONS, and proposed coding standards. + `FAQ' Frequently Asked Questions and answers. + `ChangeLog' documents changes to slib. + `slib.texi' has documentation on library packages in TexInfo format. + + `Template.scm' Example configuration file. Copy and customize to + reflect your system. + `chez.init' is a configuration file for Chez Scheme. + `elk.init' is a configuration file for ELK 2.1 + `gambit.init' is a configuration file for Gambit Scheme. + `macscheme.init' is a configuration file for MacScheme. + `mitscheme.init' is a configuration file for MIT Scheme. + `mitcomp.pat' is a patch file which adds definitions to SLIB files + for the MitScheme compiler. + `scheme2c.init' is a configuration file for DEC's scheme->c. + `scheme48.init' is a configuration file for Scheme48. + `t3.init' is a configuration file for T3.1 in Scheme mode. + `vscm.init' is a configuration file for VSCM. + `require.scm' has code which allows system independent access to + the library files. + + `format.scm' has Common-Lisp style format. + `formatst.scm' has code to test format.scm + `pp.scm' has pretty-print. + `ppfile.scm' has pprint-file and pprint-filter-file. + `obj2str.scm' has object->string. + `strcase.scm' has functions for manipulating the case of strings. + `genwrite.scm' has a generic-write which is used by pp.scm, + pp2str.scm and obj2str.scm + `printf.scm' has printf, fprintf, and sprintf compatible with C. + `scanf.scm' has scanf, fscanf, and sscanf compatible by C. + `lineio' has line oriented input/output functions. + `qp.scm' has printer safe for circular structures. + `break.scm' has break and continue. + `trace.scm' has trace and untrace for tracing function execution. + `debug.scm' has handy higher level debugging aids. + `strport.scm' has routines for string-ports. + `strsrch.scm' search for chars or substrings in strings and ports. + + `alist.scm' has functions accessing and modifying association lists. + `hash.scm' defines hash, hashq, and hashv. + `hashtab.scm' has hash tables. + `sierpinski.scm' 2-dimensional coordinate hash. + `soundex.scm' English name hash. + `logical.scm' emulates 2's complement logical operations. + `random.scm' has random number generator compatible with Common Lisp. + `randinex.scm' has inexact real number distributions. + `primes.scm' has primes and probably-prime?. + `factor.scm' has factor. + `root.scm' has Newton's and Laguerre's methods for finding roots. + `charplot.scm' has procedure for plotting on character screens. + `plottest.scm' has code to test charplot.scm. + `tek40.scm' has routines for Tektronix 4000 series graphics. + `tek41.scm' has routines for Tektronix 4100 series graphics. + `getopt.scm' has posix-like getopt for parsing command line arguments. + `time.scm' has Posix time conversion routines. + `cltime.scm' has Common-Lisp time conversion routines. + `comparse.scm' has shell-like command parsing. + + `rdms.scm' has code to construct a relational database from a base + table implementation. + `alistab.scm' has association list base tables. + `dbutil.scm' has utilities for creating and manipulating relational + databases. + `dbrowse.scm' browses relational databases. + `paramlst.scm' has procedures for passing parameters by name. + `report.scm' prints database reports. + `batch.scm' Group and execute commands on various operating systems. + `makcrc.scm' Create Scheme procedure to calculate POSIX.2 checksums + or other CRCs. + + `record.scm' a MITScheme user-definable datatypes package + `promise.scm' has code from R4RS for supporting DELAY and FORCE. + + `repl.scm' has a read-eval-print-loop. + `defmacex.scm' has defmacro:expand*. + `mbe.scm' has "Macro by Example" define-syntax. + `scmacro.scm' is a syntactic closure R4RS macro package. + r4rsyn.scm, synclo.scm, synrul.scm have syntax definitions + and support. + `scmactst.scm' is code for testing SYNTACTIC CLOSURE macros. + `scainit.scm' is a syntax-case R4RS macro package. + scaglob.scm scamacr.scm scaoutp.scm scaexpp.scm have + syntax definitions and support. `syncase.sh' is a shell + script for producing the SLIB version from the original. + `macwork.scm' is a "Macros that work" package. + mwexpand.scm mwdenote.scm mwsynrul.scm have support. + `macrotst.scm' is code from R4RS for testing macros. + + `values.scm' is multiple values. + `queue.scm' has queues and stacks. + + `object.scm' is object oriented programming (using no macros). + `recobj.scm' is records implemented using object.scm. + `yasyn.scm' is a macro package implementing YASOS using object.scm. + + `yasos.scm' is object oriented programming (using R4RS macros). + `collect.scm' is collection operators (like CL sequences). + `priorque.scm' has code and documentation for priority queues. + `wttree.scm' has weight-balanced trees. + `wttest.scm' tests weight-balanced trees. + `process.scm' has multi-processing primitives. + `array.scm' has multi-dimensional arrays and sub-arrays. + `arraymap.scm' has array-map!, array-for-each, and array-indexes. + + `sort.scm' has sorted?, sort, sort!, merge, and merge!. + `tsort.scm' has topological-sort. + `comlist.scm' has many common list and mapping procedures. + `tree.scm' has functions dealing with trees. + `chap.scm' has functions which compare and create strings in + "chapter order". + + `sc4opt.scm' has optional rev4 procedures. + `sc4sc3.scm' has procedures to make a rev3 implementation run rev4 + code. + `sc2.scm' has rev2 procedures eliminated in subsequent versions. + `mularg.scm' redefines - and / to take more than 2 arguments. + `mulapply.scm' redefines apply to take more than 2 arguments. + `ratize.scm' has function rationalize from Revised^4 spec. + `trnscrpt.scm' has transcript-on and transcript-off from Revised^4 spec. + `withfile.scm' has with-input-from-file and with-output-to-file from R4RS. + `dynwind.scm' has proposed dynamic-wind from R5RS. + `dwindtst.scm' has routines for characterizing dynamic-wind. + `dynamic.scm' has proposed DYNAMIC data type. + `fluidlet.scm' has fluid-let syntax. + `struct.scm' has defmacros which implement RECORDS from the book: + "Essentials of Programming Languages". + `structure.scm' has syntax-case macros for the same. + `structst.scm' has test code for struct.scm. + + INSTALLATION INSTRUCTIONS + + Check the manifest in `README' to find a configuration file for your +Scheme implementation. Initialization files for most IEEE P1178 +compliant Scheme Implementations are included with this distribution. + + If the Scheme implementation supports `getenv', then the value of the +shell environment variable SCHEME_LIBRARY_PATH will be used for +`(library-vicinity)' if it is defined. Currently, Chez, Elk, +MITScheme, scheme->c, VSCM, and SCM support `getenv'. + + You should check the definitions of `software-type', +`scheme-implementation-version', `implementation-vicinity', and +`library-vicinity' in the initialization file. There are comments in +the file for how to configure it. + + Once this is done you can modify the startup file for your Scheme +implementation to `load' this initialization file. SLIB is then +installed. + + Multiple implementations of Scheme can all use the same SLIB +directory. Simply configure each implementation's initialization file +as outlined above. + + The SCM implementation does not require any initialization file as +SLIB support is already built in to SCM. See the documentation with +SCM for installation instructions. + + SLIB includes methods to create heap images for the VSCM and Scheme48 +implementations. The instructions for creating a VSCM image are in +comments in `vscm.init'. To make a Scheme48 image, `cd' to the SLIB +directory and type `make slib48'. This will also create a shell script +with the name `slib48' which will invoke the saved image. + + PORTING INSTRUCTIONS + + If there is no initialization file for your Scheme implementation, you +will have to create one. Your Scheme implementation must be largely +compliant with `IEEE Std 1178-1990' or `Revised^4 Report on the +Algorithmic Language Scheme' to support SLIB. + + `Template.scm' is an example configuration file. The comments inside +will direct you on how to customize it to reflect your system. Give +your new initialization file the implementation's name with `.init' +appended. For instance, if you were porting `foo-scheme' then the +initialization file might be called `foo.init'. + + Your customized version should then be loaded as part of your scheme +implementation's initialization. It will load `require.scm' from the +library; this will allow the use of `provide', `provided?', and +`require' along with the "vicinity" functions. The rest of the +library will then be accessible in a system independent fashion. + + Please mail new working configuration files to `jaffer@ai.mit.edu' so +that they can be included in the SLIB distribution. + + CODING STANDARDS + + All library packages are written in IEEE P1178 Scheme and assume that +a configuration file and `require.scm' package have already been +loaded. Other versions of Scheme can be supported in library packages +as well by using, for example, `(provided? 'rev3-report)' or `(require +'rev3-report)'. + + `require.scm' defines `*catalog*', an association list of module +names and filenames. When a new package is added to the library, an +entry should be added to `require.scm'. Local packages can also be +added to `*catalog*' and even shadow entries already in the table. + + The module name and `:' should prefix each symbol defined in the +package. Definitions for external use should then be exported by having +`(define foo module-name:foo)'. + + Submitted packages should not duplicate routines which are already in +SLIB files. Use `require' to force those features to be supported in +your package. Care should be taken that there are no circularities in +the `require's and `load's between the library packages. + + Documentation should be provided in Emacs Texinfo format if possible, +But documentation must be provided. diff --git a/Template.scm b/Template.scm new file mode 100644 index 0000000..a03b76b --- /dev/null +++ b/Template.scm @@ -0,0 +1,267 @@ +;"Template.scm" configuration template of *features* for Scheme -*-scheme-*- +; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; (software-type) should be set to the generic operating system type. +;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. + +(define (software-type) 'UNIX) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. + +(define (scheme-implementation-type) 'Template) + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "?") + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. + +(define (implementation-vicinity) + (case (software-type) + ((UNIX) "/usr/local/src/scheme/") + ((VMS) "scheme$src:") + ((MS-DOS) "C:\\scheme\\"))) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +(define library-vicinity + (let ((library-path + (or + ;; Use this getenv if your implementation supports it. + (getenv "SCHEME_LIBRARY_PATH") + ;; Use this path if your scheme does not support GETENV + ;; or if SCHEME_LIBRARY_PATH is not set. + (case (software-type) + ((UNIX) "/usr/local/lib/slib/") + ((VMS) "lib$scheme:") + ((MS-DOS) "C:\\SLIB\\") + (else ""))))) + (lambda () library-path))) + +;;; *FEATURES* should be set to a list of symbols describing features +;;; of this implementation. Suggestions for features are: + +(define *features* + '( + source ;can load scheme source files + ;(slib:load-source "filename") +; compiled ;can load compiled files + ;(slib:load-compiled "filename") +; rev4-report ;conforms to +; rev3-report ;conforms to +; ieee-p1178 ;conforms to +; sicp ;runs code from Structure and + ;Interpretation of Computer + ;Programs by Abelson and Sussman. +; rev4-optional-procedures ;LIST-TAIL, STRING->LIST, + ;LIST->STRING, STRING-COPY, + ;STRING-FILL!, LIST->VECTOR, + ;VECTOR->LIST, and VECTOR-FILL! +; rev2-procedures ;SUBSTRING-MOVE-LEFT!, + ;SUBSTRING-MOVE-RIGHT!, + ;SUBSTRING-FILL!, + ;STRING-NULL?, APPEND!, 1+, + ;-1+, ?, >=? +; multiarg/and- ;/ and - can take more than 2 args. +; multiarg-apply ;APPLY can take more than 2 args. +; rationalize +; delay ;has DELAY and FORCE +; with-file ;has WITH-INPUT-FROM-FILE and + ;WITH-OUTPUT-FROM-FILE +; string-port ;has CALL-WITH-INPUT-STRING and + ;CALL-WITH-OUTPUT-STRING +; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF +; char-ready? +; macro ;has R4RS high level macros +; defmacro ;has Common Lisp DEFMACRO +; eval ;SLIB:EVAL is single argument eval +; record ;has user defined data structures +; values ;proposed multiple values +; dynamic-wind ;proposed dynamic-wind +; ieee-floating-point ;conforms to + full-continuation ;can return multiple times +; object-hash ;has OBJECT-HASH + +; sort +; queue ;queues +; pretty-print +; object->string +; format +; trace ;has macros: TRACE and UNTRACE +; compiler ;has (COMPILER) +; ed ;(ED) is editor +; system ;posix (system ) + getenv ;posix (getenv ) +; program-arguments ;returns list of strings (argv) +; Xwindows ;X support +; curses ;screen management package +; termcap ;terminal description package +; terminfo ;sysV terminal description +; current-time ;returns time in seconds since 1/1/1970 + )) + +;;; (OUTPUT-PORT-WIDTH ) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT ) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +(define current-error-port + (let ((port (current-output-port))) + (lambda () port))) + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (string-append "slib_" (number->string cntr))))) + +;;; (FILE-EXISTS? ) +(define (file-exists? f) #f) + +;;; (DELETE-FILE ) +(define (delete-file f) #f) + +;;; FORCE-OUTPUT flushes any pending output on optional arg output port +;;; use this definition if your system doesn't have such a procedure. +(define (force-output . arg) #t) + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-*PUT-FILE. + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +(define char-code-limit 256) + +;;; MOST-POSITIVE-FIXNUM is used in modular.scm +(define most-positive-fixnum #x0FFFFFFF) + +;;; Return argument +(define (identity x) x) + +;;; If your implementation provides eval SLIB:EVAL is single argument +;;; eval using the top-level (user) environment. +;(define slib:eval eval) + +;;; If your implementation provides R4RS macros: +;(define macro:eval slib:eval) +;(define macro:load load) + +(define *defmacros* + (list (cons 'defmacro + (lambda (name parms . body) + `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) + *defmacros*)))))) +(define (defmacro? m) (and (assq m *defmacros*) #t)) + +(define (macroexpand-1 e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) (set! a (assq a *defmacros*)) + (if a (apply (cdr a) (cdr e)) e)) + (else e))) + e)) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) + (set! a (assq a *defmacros*)) + (if a (macroexpand (apply (cdr a) (cdr e))) e)) + (else e))) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +(define base:eval slib:eval) +(define (defmacro:eval x) (base:eval (defmacro:expand* x))) +(define (defmacro:expand* x) + (require 'defmacroexpand) (apply defmacro:expand* x '())) + +(define (defmacro:load ) + (slib:eval-load defmacro:eval)) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;;; define an error procedure for the library +;(define slib:error error) + +;;; define these as appropriate for your system. +(define slib:tab (integer->char 9)) +(define slib:form-feed (integer->char 12)) + +;;; Support for older versions of Scheme. Not enough code for its own file. +(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) +(define t #t) +(define nil #f) + +;;; Define these if your implementation's syntax can support it and if +;;; they are not already defined. + +;(define (1+ n) (+ n 1)) +;(define (-1+ n) (+ n -1)) +;(define 1- -1+) + +(define in-vicinity string-append) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:exit (lambda args #f)) + +;;; Here for backward compatability +(define scheme-file-suffix + (let ((suffix (case (software-type) + ((NOSVE) "_scm") + (else ".scm")))) + (lambda () suffix))) + +;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;; suffix all the module files in SLIB have. See feature 'SOURCE. + +(define (slib:load-source f) (load (string-append f ".scm"))) + +;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;; by compiling "foo.scm" if this implementation can compile files. +;;; See feature 'COMPILED. + +(define slib:load-compiled load) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) + +(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/alist.scm b/alist.scm new file mode 100644 index 0000000..65ddb22 --- /dev/null +++ b/alist.scm @@ -0,0 +1,66 @@ +;;;"alist.scm", alist functions for Scheme. +;;;Copyright (c) 1992, 1993 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define (predicate->asso pred) + (cond ((eq? eq? pred) assq) + ((eq? = pred) assv) + ((eq? eqv? pred) assv) + ((eq? char=? pred) assv) + ((eq? equal? pred) assoc) + ((eq? string=? pred) assoc) + (else (lambda (key alist) + (let l ((al alist)) + (cond ((null? al) #f) + ((pred key (caar al)) (car al)) + (else (l (cdr al))))))))) + +(define (alist-inquirer pred) + (let ((assofun (predicate->asso pred))) + (lambda (alist key) + (let ((pair (assofun key alist))) + (and pair (cdr pair)))))) + +(define (alist-associator pred) + (let ((assofun (predicate->asso pred))) + (lambda (alist key val) + (let* ((pair (assofun key alist))) + (cond (pair (set-cdr! pair val) + alist) + (else (cons (cons key val) alist))))))) + +(define (alist-remover pred) + (lambda (alist key) + (cond ((null? alist) alist) + ((pred key (caar alist)) (cdr alist)) + ((null? (cdr alist)) alist) + ((pred key (caadr alist)) + (set-cdr! alist (cddr alist)) alist) + (else + (let l ((al (cdr alist))) + (cond ((null? (cdr al)) alist) + ((pred key (caadr al)) + (set-cdr! al (cddr al)) alist) + (else (l (cdr al))))))))) + +(define (alist-map proc alist) + (map (lambda (pair) (cons (car pair) (proc (car pair) (cdr pair)))) + alist)) + +(define (alist-for-each proc alist) + (for-each (lambda (pair) (proc (car pair) (cdr pair))) alist)) diff --git a/alistab.scm b/alistab.scm new file mode 100644 index 0000000..c8149bf --- /dev/null +++ b/alistab.scm @@ -0,0 +1,227 @@ +;;; "alistab.scm" database tables using association lists (assoc) +; Copyright 1994 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; LLDB is (filename . alist-table) +;;; HANDLE is (table-name . TABLE) +;;; TABLE is an alist of (Primary-key . ROW) +;;; ROW is a list of non-primary VALUEs + +(define alist-table +(let ((catalog-id 0) + (resources '*base-resources*)) + +(define (make-base filename dim types) + (list filename + (list catalog-id) + (list resources (list 'free-id 1)))) + +(define (open-base infile writable) + (cons (if (input-port? infile) #f infile) + ((lambda (fun) + (if (input-port? infile) + (fun infile) + (call-with-input-file infile fun))) + read))) + +(define (write-base lldb outfile) + ((lambda (fun) + (cond ((output-port? outfile) (fun outfile)) + ((string? outfile) (call-with-output-file outfile fun)) + (else #f))) + (lambda (port) + (display (string-append + ";;; \"" outfile "\" SLIB alist-table database -*-scheme-*-") + port) + (newline port) (newline port) + (display "(" port) (newline port) + (for-each + (lambda (table) + (display " (" port) + (write (car table) port) (newline port) + (for-each + (lambda (row) + (display " " port) (write row port) (newline port)) + (cdr table)) + (display " )" port) (newline port)) + (cdr lldb)) + (display ")" port) (newline port) +; (require 'pretty-print) +; (pretty-print (cdr lldb) port) + (set-car! lldb (if (string? outfile) outfile #f)) + #t))) + +(define (sync-base lldb) + (cond ((car lldb) (write-base lldb (car lldb)) #t) + (else +;;; (display "sync-base: database filename not known") + #f))) + +(define (close-base lldb) + (cond ((car lldb) (write-base lldb (car lldb)) + (set-cdr! lldb #f) + (set-car! lldb #f) #t) + ((cdr lldb) (set-cdr! lldb #f) + (set-car! lldb #f) #t) + (else +;;; (display "close-base: database not open") + #f))) + +(define (make-table lldb dim types) + (let ((free-hand (open-table lldb resources 1 '(atom integer)))) + (and free-hand + (let* ((row (remover free-hand 'free-id)) + (id #f)) + (cond (row + (set! id (car row)) + ((make-putter 1 '(atom integer)) free-hand 'free-id + (list (+ 1 id))) + (set-cdr! lldb (cons (list id) (cdr lldb))) + id) + (else #f)))))) + +(define (open-table lldb base-id dim types) + (assoc base-id (cdr lldb))) + +(define (remover nalist key) + (let ((alist (cdr nalist))) + (cond ((null? alist) #f) + ((equal? key (caar alist)) + (set-cdr! nalist (cdr alist)) + (cdar alist)) + ((null? (cdr alist)) #f) + ((equal? key (caadr alist)) + (set! nalist (cdadr alist)) + (set-cdr! alist (cddr alist)) + nalist) + (else + (let l ((al (cdr alist))) + (cond ((null? (cdr al)) #f) + ((equal? key (caadr al)) + (set! nalist (caadr al)) + (set-cdr! al (cddr al)) + nalist) + (else (l (cdr al))))))))) + +(define (kill-table lldb base-id dim types) + (and (remover lldb base-id) #t)) + +(define handle->base-id car) +(define handle->alist cdr) +(define set-handle-alist! set-cdr!) + +(define (present? handle key) + (assoc key (handle->alist handle))) + +(define (make-putter prinum types) + (lambda (handle ckey restcols) + (let ((row (assoc ckey (handle->alist handle)))) + (cond (row (set-cdr! row restcols)) + (else (set-handle-alist! + handle (cons (cons ckey restcols) + (handle->alist handle)))))))) + +(define (make-getter prinum types) + (lambda (handle ckey) + (let ((row (assoc ckey (handle->alist handle)))) + (and row (cdr row))))) + +(define (make-list-keyifier prinum types) + (if (= 1 prinum) car list->vector)) + +(define (make-keyifier-1 type) + identity) + +(define (make-key->list prinum types) + (cond ((= 1 prinum) list) + (else vector->list))) + +(define (make-key-extractor primary-limit column-type-list index) + (if (= 1 primary-limit) identity + (let ((i (+ -1 index))) + (lambda (v) (vector-ref v i))))) + +(define (for-each-key handle operation) + (for-each (lambda (x) (operation (car x))) (handle->alist handle))) + +(define (map-key handle operation) + (map (lambda (x) (operation (car x))) (handle->alist handle))) + +(define (ordered-for-each-key handle operation) + (define (key->sortable k) + (cond ((number? k) k) + ((string? k) k) + ((symbol? k) (symbol->string k)) + ((vector? k) (map key->sortable (vector->list k))) + (else (slib:error "unsortable key" k)))) + ;; This routine assumes that the car of its operands are either + ;; numbers or strings (or lists of those). + (define (car-key-< x y) + (key-< (car x) (car y))) + (define (key-< x y) + (cond ((and (number? x) (number? y)) (< x y)) + ((number? x) #t) + ((number? y) #f) + ((string? x) (stringsortable (car p)) + (car p))) + (handle->alist handle)) + car-key-<)))) + +(define (supported-type? type) + (case type + ((base-id atom integer boolean string symbol expression) #t) + (else #f))) + +(define (supported-key-type? type) + (case type + ((atom integer symbol string) #t) + (else #f))) + + (lambda (operation-name) + (case operation-name + ((make-base) make-base) + ((open-base) open-base) + ((write-base) write-base) + ((sync-base) sync-base) + ((close-base) close-base) + ((make-table) make-table) + ((open-table) open-table) + ((kill-table) kill-table) + ((make-keyifier-1) make-keyifier-1) + ((make-list-keyifier) make-list-keyifier) + ((make-key->list) make-key->list) + ((make-key-extractor) make-key-extractor) + ((supported-type?) supported-type?) + ((supported-key-type?) supported-key-type?) + ((present?) present?) + ((make-putter) make-putter) + ((make-getter) make-getter) + ((delete) remover) + ((for-each-key) for-each-key) + ((map-key) map-key) + ((ordered-for-each-key) ordered-for-each-key) + ((catalog-id) catalog-id) + (else #f) + )) + )) diff --git a/array.scm b/array.scm new file mode 100644 index 0000000..3eecb7a --- /dev/null +++ b/array.scm @@ -0,0 +1,279 @@ +;;;;"array.scm" Arrays for Scheme +; Copyright (C) 1993 Alan Bawden +; +; Permission to copy this software, to redistribute it, and to use it +; for any purpose is granted, subject to the following restrictions and +; understandings. +; +; 1. Any copy made of this software must include this copyright notice +; in full. +; +; 2. Users of this software agree to make their best efforts (a) to +; return to me any improvements or extensions that they make, so that +; these may be included in future releases; and (b) to inform me of +; noteworthy uses of this software. +; +; 3. I have made no warrantee or representation that the operation of +; this software will be error-free, and I am under no obligation to +; provide any services, by way of maintenance, update, or otherwise. +; +; 4. In conjunction with products arising from the use of this material, +; there shall be no use of my name in any advertising, promotional, or +; sales literature without prior written consent in each case. +; +; Alan Bawden +; MIT Room NE43-510 +; 545 Tech. Sq. +; Cambridge, MA 02139 +; Alan@LCS.MIT.EDU + +(require 'record) + +;(declare (usual-integrations)) + +(define array:rtd + (make-record-type "Array" + '(indexer ; Must be a -linear- function! + shape ; Inclusive bounds: ((lower upper) ...) + vector ; The actual contents + ))) + +(define array:indexer (record-accessor array:rtd 'indexer)) +(define array-shape (record-accessor array:rtd 'shape)) +(define array:vector (record-accessor array:rtd 'vector)) + +(define array? (record-predicate array:rtd)) + +(define (array-rank obj) + (if (array? obj) (length (array-shape obj)) 0)) + +(define (array-dimensions ra) + (map (lambda (ind) (if (zero? (car ind)) (cadr ind) ind)) + (array-shape ra))) + +(define array:construct + (record-constructor array:rtd '(shape vector indexer))) + +(define (array:compute-shape specs) + (map (lambda (spec) + (cond ((and (integer? spec) + (< 0 spec)) + (list 0 (- spec 1))) + ((and (pair? spec) + (pair? (cdr spec)) + (null? (cddr spec)) + (integer? (car spec)) + (integer? (cadr spec)) + (<= (car spec) (cadr spec))) + spec) + (else (slib:error "array: Bad array dimension: " spec)))) + specs)) + +(define (make-array initial-value . specs) + (let ((shape (array:compute-shape specs))) + (let loop ((size 1) + (indexer (lambda () 0)) + (l (reverse shape))) + (if (null? l) + (array:construct shape + (make-vector size initial-value) + (array:optimize-linear-function indexer shape)) + (loop (* size (+ 1 (- (cadar l) (caar l)))) + (lambda (first-index . rest-of-indices) + (+ (* size (- first-index (caar l))) + (apply indexer rest-of-indices))) + (cdr l)))))) + +(define (make-shared-array array mapping . specs) + (let ((new-shape (array:compute-shape specs)) + (old-indexer (array:indexer array))) + (let check ((indices '()) + (bounds (reverse new-shape))) + (cond ((null? bounds) + (array:check-bounds array (apply mapping indices))) + (else + (check (cons (caar bounds) indices) (cdr bounds)) + (check (cons (cadar bounds) indices) (cdr bounds))))) + (array:construct new-shape + (array:vector array) + (array:optimize-linear-function + (lambda indices + (apply old-indexer (apply mapping indices))) + new-shape)))) + +(define (array:in-bounds? array indices) + (let loop ((indices indices) + (shape (array-shape array))) + (if (null? indices) + (null? shape) + (let ((index (car indices))) + (and (not (null? shape)) + (integer? index) + (<= (caar shape) index (cadar shape)) + (loop (cdr indices) (cdr shape))))))) + +(define (array:check-bounds array indices) + (or (array:in-bounds? array indices) + (slib:error "array: Bad indices for " array indices))) + +(define (array-ref array . indices) + (array:check-bounds array indices) + (vector-ref (array:vector array) + (apply (array:indexer array) indices))) + +(define (array-set! array new-value . indices) + (array:check-bounds array indices) + (vector-set! (array:vector array) + (apply (array:indexer array) indices) + new-value)) + +(define (array-in-bounds? array . indices) + (array:in-bounds? array indices)) + +; Fast versions of ARRAY-REF and ARRAY-SET! that do no error checking, +; and don't cons intermediate lists of indices: + +(define (array-1d-ref a i0) + (vector-ref (array:vector a) ((array:indexer a) i0))) + +(define (array-2d-ref a i0 i1) + (vector-ref (array:vector a) ((array:indexer a) i0 i1))) + +(define (array-3d-ref a i0 i1 i2) + (vector-ref (array:vector a) ((array:indexer a) i0 i1 i2))) + +(define (array-1d-set! a v i0) + (vector-set! (array:vector a) ((array:indexer a) i0) v)) + +(define (array-2d-set! a v i0 i1) + (vector-set! (array:vector a) ((array:indexer a) i0 i1) v)) + +(define (array-3d-set! a v i0 i1 i2) + (vector-set! (array:vector a) ((array:indexer a) i0 i1 i2) v)) + +; STOP! Do not read beyond this point on your first reading of +; this code -- you should simply assume that the rest of this file +; contains only the following single definition: +; +; (define (array:optimize-linear-function f l) f) +; +; Of course everything would be pretty inefficient if this were really the +; case, but it isn't. The following code takes advantage of the fact that +; you can learn everything there is to know from a linear function by +; simply probing around in its domain and observing its values -- then a +; more efficient equivalent can be constructed. + +(define (array:optimize-linear-function f l) + (let ((d (length l))) + (cond + ((= d 0) + (array:0d-c (f))) + ((= d 1) + (let ((c (f 0))) + (array:1d-c0 c (- (f 1) c)))) + ((= d 2) + (let ((c (f 0 0))) + (array:2d-c01 c (- (f 1 0) c) (- (f 0 1) c)))) + ((= d 3) + (let ((c (f 0 0 0))) + (array:3d-c012 c (- (f 1 0 0) c) (- (f 0 1 0) c) (- (f 0 0 1) c)))) + (else + (let* ((v (map (lambda (x) 0) l)) + (c (apply f v))) + (let loop ((p v) + (old-val c) + (coefs '())) + (cond ((null? p) + (array:Nd-c* c (reverse coefs))) + (else + (set-car! p 1) + (let ((new-val (apply f v))) + (loop (cdr p) + new-val + (cons (- new-val old-val) coefs))))))))))) + +; 0D cases: + +(define (array:0d-c c) + (lambda () c)) + +; 1D cases: + +(define (array:1d-c c) + (lambda (i0) (+ c i0))) + +(define (array:1d-0 n0) + (cond ((= 1 n0) +) + (else (lambda (i0) (* n0 i0))))) + +(define (array:1d-c0 c n0) + (cond ((= 0 c) (array:1d-0 n0)) + ((= 1 n0) (array:1d-c c)) + (else (lambda (i0) (+ c (* n0 i0)))))) + +; 2D cases: + +(define (array:2d-0 n0) + (lambda (i0 i1) (+ (* n0 i0) i1))) + +(define (array:2d-1 n1) + (lambda (i0 i1) (+ i0 (* n1 i1)))) + +(define (array:2d-c0 c n0) + (lambda (i0 i1) (+ c (* n0 i0) i1))) + +(define (array:2d-c1 c n1) + (lambda (i0 i1) (+ c i0 (* n1 i1)))) + +(define (array:2d-01 n0 n1) + (cond ((= 1 n0) (array:2d-1 n1)) + ((= 1 n1) (array:2d-0 n0)) + (else (lambda (i0 i1) (+ (* n0 i0) (* n1 i1)))))) + +(define (array:2d-c01 c n0 n1) + (cond ((= 0 c) (array:2d-01 n0 n1)) + ((= 1 n0) (array:2d-c1 c n1)) + ((= 1 n1) (array:2d-c0 c n0)) + (else (lambda (i0 i1) (+ c (* n0 i0) (* n1 i1)))))) + +; 3D cases: + +(define (array:3d-01 n0 n1) + (lambda (i0 i1 i2) (+ (* n0 i0) (* n1 i1) i2))) + +(define (array:3d-02 n0 n2) + (lambda (i0 i1 i2) (+ (* n0 i0) i1 (* n2 i2)))) + +(define (array:3d-12 n1 n2) + (lambda (i0 i1 i2) (+ i0 (* n1 i1) (* n2 i2)))) + +(define (array:3d-c12 c n1 n2) + (lambda (i0 i1 i2) (+ c i0 (* n1 i1) (* n2 i2)))) + +(define (array:3d-c02 c n0 n2) + (lambda (i0 i1 i2) (+ c (* n0 i0) i1 (* n2 i2)))) + +(define (array:3d-c01 c n0 n1) + (lambda (i0 i1 i2) (+ c (* n0 i0) (* n1 i1) i2))) + +(define (array:3d-012 n0 n1 n2) + (cond ((= 1 n0) (array:3d-12 n1 n2)) + ((= 1 n1) (array:3d-02 n0 n2)) + ((= 1 n2) (array:3d-01 n0 n1)) + (else (lambda (i0 i1 i2) (+ (* n0 i0) (* n1 i1) (* n2 i2)))))) + +(define (array:3d-c012 c n0 n1 n2) + (cond ((= 0 c) (array:3d-012 n0 n1 n2)) + ((= 1 n0) (array:3d-c12 c n1 n2)) + ((= 1 n1) (array:3d-c02 c n0 n2)) + ((= 1 n2) (array:3d-c01 c n0 n1)) + (else (lambda (i0 i1 i2) (+ c (* n0 i0) (* n1 i1) (* n2 i2)))))) + +; ND cases: + +(define (array:Nd-* coefs) + (lambda indices (apply + (map * coefs indices)))) + +(define (array:Nd-c* c coefs) + (cond ((= 0 c) (array:Nd-* coefs)) + (else (lambda indices (apply + c (map * coefs indices)))))) diff --git a/arraymap.scm b/arraymap.scm new file mode 100644 index 0000000..18ee64a --- /dev/null +++ b/arraymap.scm @@ -0,0 +1,76 @@ +;;;; "arraymap.scm", applicative routines for arrays in Scheme. +;;; Copyright (c) 1993 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'array) + +(define (array-map! ra0 proc . ras) + (define (ramap rshape inds) + (if (null? (cdr rshape)) + (do ((i (cadar rshape) (+ -1 i)) + (is (cons (cadar rshape) inds) + (cons (+ -1 i) inds))) + ((< i (caar rshape))) + (apply array-set! ra0 + (apply proc (map (lambda (ra) (apply array-ref ra is)) + ras)) + is)) + (let ((crshape (cdr rshape)) + (ll (caar rshape))) + (do ((i (cadar rshape) (+ -1 i))) + ((< i ll)) + (ramap crshape (cons i inds)))))) + (ramap (reverse (array-shape ra0)) '())) + +(define (array-for-each proc . ras) + (define (rafe rshape inds) + (if (null? (cdr rshape)) + (do ((i (caar rshape) (+ 1 i))) + ((> i (cadar rshape))) + (apply proc + (map (lambda (ra) + (apply array-ref ra (reverse (cons i inds)))) ras))) + (let ((crshape (cdr rshape)) + (ll (cadar rshape))) + (do ((i (caar rshape) (+ 1 i))) + ((> i ll)) + (rafe crshape (cons i inds)))))) + (rafe (array-shape (car ras)) '())) + +(define (shape->indexes shape) + (define ra0 (apply make-array '() shape)) + (define (ramap rshape inds) + (if (null? (cdr rshape)) + (do ((i (cadar rshape) (+ -1 i)) + (is (cons (cadar rshape) inds) + (cons (+ -1 i) inds))) + ((< i (caar rshape))) + (apply array-set! ra0 is is)) + (let ((crshape (cdr rshape)) + (ll (caar rshape))) + (do ((i (cadar rshape) (+ -1 i))) + ((< i ll)) + (ramap crshape (cons i inds)))))) + (ramap (reverse shape) '()) + ra0) + +(define (array-indexes ra) + (shape->indexes (array-shape ra))) + +(define (array-copy! source dest) + (array-map! dest identity source)) diff --git a/batch.scm b/batch.scm new file mode 100644 index 0000000..685dd3e --- /dev/null +++ b/batch.scm @@ -0,0 +1,417 @@ +;;; "batch.scm" Group and execute commands on various systems. +;Copyright (C) 1994, 1995 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'line-i/o) ;Just for write-line +(require 'parameters) +(require 'database-utilities) + +;;(define (batch parms op . args) ??) + +(define (batch:port parms) + (car (parameter-list-ref parms 'batch-port))) + +(define (batch:dialect parms) ; was batch-family + (car (parameter-list-ref parms 'batch-dialect))) + +(define (batch:line-length-limit parms) + (let ((bl (parameter-list-ref parms 'batch-line-length-limit))) + (cond (bl (car bl)) + (else (case (batch:dialect parms) + ((unix) 1023) + ((dos) 127) + ((vms) 1023) + ((system) 1023) + ((*unknown*) -1)))))) + +(define (batch-line parms str) + (let ((bp (parameter-list-ref parms 'batch-port)) + (ln (batch:line-length-limit parms))) + (cond ((not bp) (slib:error 'batch-line "missing batch-port parameter" + parms)) + ((>= (string-length str) ln) #f) + (else (write-line str (car bp)) #t)))) + +;;; add a Scheme batch-dialect? + +(define (batch:apply-chop-to-fit proc . args) + (define args-but-last (butlast args 1)) + (let loop ((fodder (car (last-pair args)))) + (let ((hlen (quotient (length fodder) 2))) + (cond ((apply proc (append args-but-last (list fodder)))) + ((not (positive? hlen)) + (slib:error 'batch:apply-chop-to-fit "can't split" + (cons proc (append args-but-last (list fodder))))) + (else (loop (nthcdr (+ 1 hlen) fodder)) + (loop (butlast fodder hlen))))))) + +(define (batch:system parms . strings) + (or (apply batch:try-system parms strings) + (slib:error 'batch:system 'failed strings))) + +(define (batch:try-system parms . strings) + (define port (batch:port parms)) + (set! strings (batch:flatten strings)) + (case (batch:dialect parms) + ((unix) (batch-line parms (apply string-join " " strings))) + ((dos) (batch-line parms (apply string-join " " strings))) + ((vms) (batch-line parms (apply string-join " " "$" strings))) + ((system) (write `(system ,(apply string-join " " strings)) port) + (newline port) + (zero? (system (apply string-join " " strings)))) + ((*unknown*) (write `(system ,(apply string-join " " strings)) port) + (newline port) + #f))) + +(define (batch:run-script parms . strings) + (case (batch:dialect parms strings) + ((unix) (batch:system parms strings name)) + ((dos) (batch:system parms strings name)) + ((vms) (batch:system parms (cons #\@ strings))) + ((system) (batch:system parms strings name)) + ((*unknown*) (batch:system parms strings name) + #f))) + +(define (batch:comment parms . lines) + (define port (batch:port parms)) + (set! lines (batch:flatten lines)) + (case (batch:dialect parms) + ((unix) (every (lambda (line) + (batch-line parms (string-append "# " line))) + lines)) + ((dos) (every (lambda (line) + (batch-line parms + (string-append + "rem" (if (equal? " " line) ".") line))) + lines)) + ((vms) (every (lambda (line) + (batch-line parms (string-append "$! " line))) + lines)) + ((system) (every (lambda (line) + (batch-line parms (string-append "; " line))) + lines)) + ((*unknown*) (for-each (lambda (line) + (batch-line parms (string-append ";;; " line)) + (newline port)) + lines) + #f))) + +(define (batch:lines->file parms file . lines) + (define port (batch:port parms)) + (set! lines (batch:flatten lines)) + (case (or (batch:dialect parms) '*unknown*) + ((unix) (batch-line parms (string-append "rm -f " file)) + (every + (lambda (string) + (batch-line parms (string-append "echo '" string "'>>" file))) + lines)) + ((dos) (batch-line parms (string-append "DEL " file)) + (every + (lambda (string) + (batch-line parms + (string-append "ECHO" (if (equal? "" string) "." " ") + string ">>" file))) + lines)) + ((vms) (and (batch-line parms (string-append "$DELETE " file)) + (batch-line parms (string-append "$CREATE " file)) + (batch-line parms (string-append "$DECK")) + (every (lambda (string) (batch-line parms string)) + lines) + (batch-line parms (string-append "$EOD")))) + ((system) (write `(delete-file ,file) port) (newline port) + (delete-file file) + (pretty-print `(call-with-output-file ,file + (lambda (fp) + (for-each + (lambda (string) (write-line string fp)) + ',lines))) + port) + (call-with-output-file file + (lambda (fp) (for-each (lambda (string) (write-line string fp)) + lines))) + #t) + ((*unknown*) + (write `(delete-file ,file) port) (newline port) + (pretty-print + `(call-with-output-file ,file + (lambda (fp) + (for-each + (lambda (string) + (write-line string fp)) + ,lines))) + port) + #f))) + +(define (batch:delete-file parms file) + (define port (batch:port parms)) + (case (batch:dialect parms) + ((unix) (batch-line parms (string-append "rm -f " file)) + #t) + ((dos) (batch-line parms (string-append "DEL " file)) + #t) + ((vms) (batch-line parms (string-append "$DELETE " file)) + #t) + ((system) (write `(delete-file ,file) port) (newline port) + (delete-file file)) ; SLIB provides + ((*unknown*) (write `(delete-file ,file) port) (newline port) + #f))) + +(define (batch:rename-file parms old-name new-name) + (define port (batch:port parms)) + (case (batch:dialect parms) + ((unix) (batch-line parms (string-join " " "mv -f" old-name new-name))) + ((dos) (batch-line parms (string-join " " "MOVE" "/Y" old-name new-name))) + ((vms) (batch-line parms (string-join " " "$RENAME" old-name new-name))) + ((system) (batch:extender 'rename-file batch:rename-file)) + ((*unknown*) (write `(rename-file ,old-name ,new-name) port) + (newline port) + #f))) + +(define (batch:call-with-output-script parms name proc) + (case (batch:dialect parms) + ((unix) ((cond ((string? name) + (lambda (proc) + (let ((ans (call-with-output-file name proc))) + (system (string-append "chmod +x " name)) + ans))) + ((output-port? name) (lambda (proc) (proc name))) + (else (lambda (proc) (proc (current-output-port))))) + (lambda (port) + (write-line "#!/bin/sh" port) + (cond + ((and (string? name) (provided? 'bignum)) + (require 'posix-time) + (write-line + (string-append + "# \"" name "\" build script created " + (ctime (current-time))) + port))) + (proc port)))) + + ((dos) ((cond ((string? name) + (lambda (proc) + (call-with-output-file (string-append name ".bat") proc))) + ((output-port? name) (lambda (proc) (proc name))) + (else (lambda (proc) (proc (current-output-port))))) + (lambda (port) + (cond + ((and (string? name) (provided? 'bignum)) + (require 'posix-time) + (write-line + (string-append + "rem " name + " build script created " + (ctime (current-time))) + port))) + (proc port)))) + + ((vms) ((cond ((string? name) + (lambda (proc) + (call-with-output-file (string-append name ".COM") proc))) + ((output-port? name) (lambda (proc) (proc name))) + (else (lambda (proc) (proc (current-output-port))))) + (lambda (port) + (cond + ((and (string? name) (provided? 'bignum)) + (require 'posix-time) + ;;(write-line + ;; "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port) + (write-line + (string-append + "$! " name + " build script created " + (ctime (current-time))) + port))) + (proc port)))) + + ((system) ((cond ((string? name) + (lambda (proc) + (let ((ans (call-with-output-file name + (lambda (port) (proc name))))) + (system (string-append "chmod +x " name)) + ans))) + ((output-port? name) (lambda (proc) (proc name))) + (else (lambda (proc) (proc (current-output-port))))) + (lambda (port) + (cond + ((and (string? name) (provided? 'bignum)) + (require 'posix-time) + (write-line + (string-append + ";;; \"" name + "\" build script created " (ctime (current-time))) + port))) + (proc port)))) + + ((*unknown*) ((cond ((string? name) + (lambda (proc) + (let ((ans (call-with-output-file name + (lambda (port) (proc name))))) + (system (string-append "chmod +x " name)) + ans))) + ((output-port? name) (lambda (proc) (proc name))) + (else (lambda (proc) (proc (current-output-port))))) + (lambda (port) + (cond + ((and (string? name) (provided? 'bignum)) + (require 'posix-time) + (write-line + (string-append + ";;; \"" name + "\" build script created " (ctime (current-time))) + port))) + (proc port))) + #f))) + +;;; This little ditty figures out how to use a Scheme extension or +;;; SYSTEM to execute a command that is not available in the batch +;;; mode chosen. + +(define (batch:extender NAME BATCHER) + (lambda (parms . args) + (define port (batch:port parms)) + (cond + ((provided? 'i/o-extensions) ; SCM specific + (write `(,NAME ,@args) port) + (newline port) + (apply (slib:eval NAME) args)) + (else + (let ((pl (make-parameter-list (map car parms)))) + (adjoin-parameters! + pl (cons 'batch-dialect (os->batch-dialect + (parameter-list-ref parms 'platform)))) + (system + (call-with-output-string + (lambda (port) + (batch:call-with-output-script + port + (lambda (batch-port) + (define new-parms (copy-tree pl)) + (adjoin-parameters! new-parms (list 'batch-port batch-port)) + (apply BATCHER new-parms args))))))))))) + +(define (replace-suffix str old new) + (define (cs str) + (let* ((len (string-length str)) + (re (- len (string-length old)))) + (cond ((string-ci=? old (substring str re len)) + (string-append (substring str 0 re) new)) + (else + (slib:error 'replace-suffix "suffix doens't match:" + old str))))) + (if (string? str) (cs str) (map cs str))) + +(define (must-be-first firsts lst) + (append (remove-if-not (lambda (i) (member i lst)) firsts) + (remove-if (lambda (i) (member i firsts)) lst))) + +(define (must-be-last lst lasts) + (append (remove-if (lambda (i) (member i lasts)) lst) + (remove-if-not (lambda (i) (member i lst)) lasts))) + +(define (string-join joiner . args) + (if (null? args) "" + (apply string-append + (car args) + (map (lambda (s) (string-append joiner s)) (cdr args))))) + +(define (batch:flatten strings) + (apply + append (map + (lambda (obj) + (cond ((eq? "" obj) '()) + ((string? obj) (list obj)) + ((eq? #f obj) '()) + ((null? obj) '()) + ((list? obj) (batch:flatten obj)) + (else (slib:error 'batch:flatten "unexpected type" + obj "in" strings)))) + strings))) + +(define batch:platform (software-type)) +(cond ((and (eq? 'unix batch:platform) (provided? 'system)) + (let ((file-name (tmpnam))) + (system (string-append "uname > " file-name)) + (set! batch:platform (call-with-input-file file-name read)) + (delete-file file-name)))) + +(define batch:database #f) +(define (os->batch-dialect os) + ((((batch:database 'open-table) 'operating-system #f) + 'get 'os-family) os)) + +(define (batch:initialize! database) + (set! batch:database database) + (define-tables database + + '(batch-dialect + ((family atom)) + () + ((unix) + (dos) + (vms) + (system) + (*unknown*))) + + '(operating-system + ((name symbol)) + ((os-family batch-dialect)) + (;;(3b1 *unknown*) + (acorn *unknown*) + (aix unix) + (alliant *unknown*) + (amiga *unknown*) + (apollo unix) + (apple2 *unknown*) + (arm *unknown*) + (atari.st *unknown*) + (cdc *unknown*) + (celerity *unknown*) + (concurrent *unknown*) + (convex *unknown*) + (encore *unknown*) + (harris *unknown*) + (hp-ux unix) + (hp48 *unknown*) + (isis *unknown*) + (linux unix) + (mac *unknown*) + (masscomp unix) + (ms-dos dos) + (mips *unknown*) + (ncr *unknown*) + (newton *unknown*) + (next unix) + (novell *unknown*) + (os/2 dos) + (prime *unknown*) + (psion *unknown*) + (pyramid *unknown*) + (sequent *unknown*) + (sgi *unknown*) + (stratus *unknown*) + (sun-os unix) + (transputer *unknown*) + (unicos unix) + (unix unix) + (vms vms) + (*unknown* *unknown*) + ))) + + ((database 'add-domain) '(operating-system operating-system #f symbol #f)) + ) diff --git a/break.scm b/break.scm new file mode 100644 index 0000000..e6ba634 --- /dev/null +++ b/break.scm @@ -0,0 +1,151 @@ +;;;; "break.scm" Breakpoints for debugging in Scheme. +;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'qp) + +;;;; BREAKPOINTS + +;;; Typing (init-debug) at top level sets up a continuation for +;;; breakpoint. When (breakpoint arg1 ...) is then called it returns +;;; from the top level continuation and pushes the continuation from +;;; which it was called on breakpoint:continuation-stack. If +;;; (continue) is later called, it pops the topmost continuation off +;;; of breakpoint:continuation-stack and returns #f to it. + +(define breakpoint:continuation-stack '()) + +(define debug:breakpoint + (let ((call-with-current-continuation call-with-current-continuation) + (apply apply) (qpn qpn) + (cons cons) (length length)) + (lambda args + (apply qpn "BREAKPOINT:" args) + (let ((ans + (call-with-current-continuation + (lambda (x) + (set! breakpoint:continuation-stack + (cons x breakpoint:continuation-stack)) + (debug:top-continuation + (length breakpoint:continuation-stack)))))) + (cond ((not (eq? ans breakpoint:continuation-stack)) ans)))))) + +(define debug:continue + (let ((null? null?) (car car) (cdr cdr)) + (lambda args + (cond ((null? breakpoint:continuation-stack) + (display "; no break to continue from") + (newline)) + (else + (let ((cont (car breakpoint:continuation-stack))) + (set! breakpoint:continuation-stack + (cdr breakpoint:continuation-stack)) + (if (null? args) (cont #f) + (apply cont args)))))))) + +(define debug:top-continuation + (if (provided? 'abort) + (lambda (val) (display val) (newline) (abort)) + (begin (display "; type (init-debug)") #f))) + +(define (init-debug) + (call-with-current-continuation + (lambda (x) (set! debug:top-continuation x)))) + +(define breakpoint debug:breakpoint) +(define bkpt debug:breakpoint) +(define continue debug:continue) + +(define debug:breakf + (let ((null? null?) ;These bindings are so that + (not not) ;breakf will not break on parts + (car car) (cdr cdr) ;of itself. + (eq? eq?) (+ +) (zero? zero?) (modulo modulo) + (apply apply) (display display) (breakpoint debug:breakpoint)) + (lambda (function . optname) +;;; (set! debug:indent 0) + (let ((name (if (null? optname) function (car optname)))) + (lambda args + (cond ((and (not (null? args)) + (eq? (car args) 'debug:unbreak-object) + (null? (cdr args))) + function) + (else + (breakpoint name args) + (apply function args)))))))) + +;;; the reason I use a symbol for debug:unbreak-object is so +;;; that functions can still be unbreaked if this file is read in twice. + +(define (debug:unbreakf function) +;;; (set! debug:indent 0) + (function 'debug:unbreak-object)) + +;;;;The break: functions wrap around the debug: functions to provide +;;; niceties like keeping track of breakd functions and dealing with +;;; redefinition. + +(require 'alist) +(define break:adder (alist-associator eq?)) +(define break:deler (alist-remover eq?)) + +(define *breakd-procedures* '()) +(define (break:breakf fun sym) + (cond ((not (procedure? fun)) + (display "WARNING: not a procedure " (current-error-port)) + (display sym (current-error-port)) + (newline (current-error-port)) + (set! *breakd-procedures* (break:deler *breakd-procedures* sym)) + fun) + (else + (let ((p (assq sym *breakd-procedures*))) + (cond ((and p (eq? (cdr p) fun)) + fun) + (else + (let ((tfun (debug:breakf fun sym))) + (set! *breakd-procedures* + (break:adder *breakd-procedures* sym tfun)) + tfun))))))) + +(define (break:unbreakf fun sym) + (let ((p (assq sym *breakd-procedures*))) + (set! *breakd-procedures* (break:deler *breakd-procedures* sym)) + (cond ((not (procedure? fun)) fun) + ((not p) fun) + ((eq? (cdr p) fun) + (debug:unbreakf fun)) + (else fun)))) + +(define breakf debug:breakf) +(define unbreakf debug:unbreakf) + +;;;; Finally, the macros break and unbreak + +(defmacro break xs + (if (null? xs) + `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) + (map car *breakd-procedures*)) + (map car *breakd-procedures*)) + `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) xs)))) +(defmacro unbreak xs + (if (null? xs) + (slib:eval + `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x))) + (map car *breakd-procedures*)) + '',(map car *breakd-procedures*))) + `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x))) xs)))) diff --git a/chap.scm b/chap.scm new file mode 100644 index 0000000..ed559c9 --- /dev/null +++ b/chap.scm @@ -0,0 +1,150 @@ +;;;; "chap.scm" Chapter ordering -*-scheme-*- +;;; Copyright 1992, 1993, 1994 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; The CHAP: functions deal with strings which are ordered like +;;; chapters in a book. For instance, a_9 < a_10 and 4c < 4aa. Each +;;; section of the string consists of consecutive numeric or +;;; consecutive aphabetic characters. + +(define (chap:string= i l1) (not (>= i l2))) + ((>= i l2) #f) + (else + (let ((c1 (string-ref s1 i)) + (c2 (string-ref s2 i))) + (cond ((char=? c1 c2) + (if (ctypep c1) + (match-so-far (+ 1 i) ctypep) + (delimited i))) + ((ctypep c1) + (if (ctypep c2) + (length-race (+ 1 i) ctypep (char= i l1) (if (>= i l2) def #t)) + ((>= i l2) #f) + (else + (let ((c1 (string-ref s1 i)) + (c2 (string-ref s2 i))) + (cond ((ctypep c1) + (if (ctypep c2) + (length-race (+ 1 i) ctypep def) + #f)) + ((ctypep c2) #t) + (else def)))))) + (define (ctype c1) + (cond + ((char-numeric? c1) char-numeric?) + ((char-lower-case? c1) char-lower-case?) + ((char-upper-case? c1) char-upper-case?) + (else #f))) + (define (delimited i) + (cond ((>= i l1) (not (>= i l2))) + ((>= i l2) #f) + (else + (let* ((c1 (string-ref s1 i)) + (c2 (string-ref s2 i)) + (ctype1 (ctype c1))) + (cond ((char=? c1 c2) + (if ctype1 (match-so-far (+ i 1) ctype1) + (delimited (+ i 1)))) + ((and ctype1 (eq? ctype1 (ctype c2))) + (length-race (+ 1 i) ctype1 (charinteger #\2) (char->integer #\1))) + +(define (chap:inc-string s p) + (let ((c (string-ref s p))) + (cond ((char=? c #\z) + (string-set! s p #\a) + (cond ((zero? p) (string-append "a" s)) + ((char-lower-case? (string-ref s (+ -1 p))) + (chap:inc-string s (+ -1 p))) + (else + (string-append + (substring s 0 p) + "a" + (substring s p (string-length s)))))) + ((char=? c #\Z) + (string-set! s p #\A) + (cond ((zero? p) (string-append "A" s)) + ((char-upper-case? (string-ref s (+ -1 p))) + (chap:inc-string s (+ -1 p))) + (else + (string-append + (substring s 0 p) + "A" + (substring s p (string-length s)))))) + ((char=? c #\9) + (string-set! s p #\0) + (cond ((zero? p) (string-append "1" s)) + ((char-numeric? (string-ref s (+ -1 p))) + (chap:inc-string s (+ -1 p))) + (else + (string-append + (substring s 0 p) + "1" + (substring s p (string-length s)))))) + ((or (char-alphabetic? c) (char-numeric? c)) + (string-set! s p (integer->char + (+ chap:char-incr + (char->integer (string-ref s p))))) + s) + (else (slib:error "inc-string error" s p))))) + +(define (chap:next-string s) + (do ((i (+ -1 (string-length s)) (+ -1 i))) + ((or (negative? i) + (char-numeric? (string-ref s i)) + (char-alphabetic? (string-ref s i))) + (if (negative? i) (string-append s "0") + (chap:inc-string (string-copy s) i))))) + +;;; testing utilities +;(define (ns s1) (chap:next-string s1)) + +;(define (ts s1 s2) +; (let ((s< (chap:string (chap:string +; (display s1) +; (display " > ") +; (display s2) +; (newline))))) + +(define (chap:string>? s1 s2) (chap:string=? s1 s2) (not (chap:stringexact (round (/ (* z (car scale)) (cadr scale)))))) + +(define (find-scale isize delta) + (if (inexact? delta) (set! isize (exact->inexact isize))) + (do ((d 1 (* d 10))) + ((<= delta isize) + (do ((n 1 (* n 10))) + ((>= (* delta 10) isize) + (list (* n (cond ((< (* delta 8) isize) 8) + ((< (* delta 6) isize) 6) + ((< (* delta 5) isize) 5) + ((< (* delta 4) isize) 4) + ((< (* delta 3) isize) 3) + ((< (* delta 2) isize) 2) + (else 1))) + d)) + (set! delta (* delta 10)))) + (set! isize (* isize 10)))) + +(define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale) + (define xaxis (- (scale-it ymin yscale))) + (define yaxis (- (scale-it xmin xscale))) + (charplot:center-print! ylabel 11) + (charplot:printn! (+ charplot:width 1) charplot:xborder) + (newline) + (set! data (sort! data (lambda (x y) (if (= (cdr x) (cdr y)) + (< (car x) (car y)) + (> (cdr x) (cdr y)))))) + (do ((ht (- charplot:height 1) (- ht 1))) + ((negative? ht)) + (let ((a (make-string (+ charplot:width 1) + (if (= ht xaxis) charplot:xaxchar #\ ))) + (ystep (if (= 1 (gcd (car yscale) 3)) 2 3))) + (string-set! a charplot:width charplot:yborder) + (if (< -1 yaxis charplot:width) (string-set! a yaxis charplot:yaxchar)) + (do () + ((or (null? data) (not (>= (cdar data) ht)))) + (string-set! a (caar data) charplot:curve1) + (set! data (cdr data))) + (if (zero? (modulo (- ht xaxis) ystep)) + (let* ((v (number->string (/ (* (- ht xaxis) (cadr yscale)) + (car yscale)))) + (l (string-length v))) + (if (> l 10) + (display (substring v 0 10)) + (begin + (charplot:printn! (- 10 l) #\ ) + (display v))) + (display charplot:yborder) + (display charplot:xaxchar)) + (begin + (charplot:printn! 10 #\ ) + (display charplot:yborder) + (display #\ ))) + (display a) (newline))) + (let* ((xstep (if (= 1 (gcd (car xscale) 3)) 10 12)) + (xstep/2 (quotient (- xstep 2) 2)) + (fudge (modulo yaxis xstep))) + (charplot:printn! 10 #\ ) (display charplot:yborder) + (charplot:printn! (+ 1 fudge) charplot:xborder) + (display charplot:yaxchar) + (do ((i fudge (+ i xstep))) + ((> (+ i xstep) charplot:width) + (charplot:printn! (modulo (- charplot:width (+ i 1)) xstep) + charplot:xborder)) + (charplot:printn! xstep/2 charplot:xborder) + (display charplot:xtick) + (charplot:printn! xstep/2 charplot:xborder) + (display charplot:yaxchar)) + (display charplot:yborder) (newline) + (charplot:center-print! xlabel (+ 12 fudge (- xstep/2))) + (do ((i fudge (+ i xstep))) + ((> (+ i xstep) charplot:width)) + (charplot:center-print! (number->string (/ (* (- i yaxis) (cadr xscale)) + (car xscale))) + xstep)) + (newline))) + +(define (charplot:plot! data xlabel ylabel) + (let* ((xmax (apply max (map car data))) + (xmin (apply min (map car data))) + (xscale (find-scale charplot:width (- xmax xmin))) + (ymax (apply max (map cdr data))) + (ymin (apply min (map cdr data))) + (yscale (find-scale charplot:height (- ymax ymin))) + (ixmin (scale-it xmin xscale)) + (iymin (scale-it ymin yscale))) + (charplot:iplot! (map (lambda (p) + (cons (- (scale-it (car p) xscale) ixmin) + (- (scale-it (cdr p) yscale) iymin))) + data) + xlabel ylabel xmin xscale ymin yscale))) + +(define plot! charplot:plot!) diff --git a/chez.init b/chez.init new file mode 100644 index 0000000..a91cce3 --- /dev/null +++ b/chez.init @@ -0,0 +1,266 @@ +;"chez.init" Initialization file for SLIB for Chez Scheme -*-scheme-*- +; Copyright (C) 1993 dorai@cs.rice.edu (Dorai Sitaram) +; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; (software-type) should be set to the generic operating system type. +;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. + +(define (software-type) 'UNIX) + +(define (scheme-implementation-type) 'Chez) + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "?") + +(define implementation-vicinity + (lambda () "/usr/local/lib/scheme/")) + +;; library-vicinity is moved below the defination of getenv + +(define *features* + '( + source ;can load scheme source files + ;(slib:load-source "filename") + compiled ;can load compiled files + ;(slib:load-compiled "filename") + char-ready? + delay + dynamic-wind + fluid-let + format + full-continuation + getenv + ieee-p1178 + macro + multiarg/and- + multiarg-apply + pretty-print + random + random-inexact + rationalize + rev3-procedures + rev3-report + rev4-optional-procedures + rev4-report + sort + system + transcript + with-file + string-port + )) + +;R4RS define-syntax in terms of Chez's extend-syntax. +;Caveat: no let-syntax + +(extend-syntax (define-syntax syntax-rules) + ((define-syntax name (syntax-rules kwds . clauses)) + (extend-syntax (name . kwds) . clauses))) + +;DEFINED? +(define-syntax defined? + (syntax-rules () + ((defined? x) (or (bound? 'x) (get 'x '*expander*))))) + +;Chez's sort routines have the opposite parameter order to Slib's +(define chez:sort sort) +(define chez:sort! sort!) +(define chez:merge merge) +(define chez:merge! merge!) + +(define sort + (lambda (s p) + (chez:sort p s))) +(define sort! + (lambda (s p) + (chez:sort! p s))) +(define merge + (lambda (s1 s2 p) + (chez:merge p s1 s2))) +(define merge! + (lambda (s1 s2 p) + (chez:merge! p s1 s2))) + +;RENAME-FILE +(define rename-file + (lambda (src dst) + (system (string-append "mv " src " " dst)))) + +;OUTPUT-PORT-WIDTH +(define output-port-width (lambda arg 79)) + +;;; (OUTPUT-PORT-HEIGHT ) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +(define current-error-port + (let ((port (current-output-port))) + (lambda () port))) + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam + (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (let ((tmp (string-append "slib_" (number->string cntr)))) + (if (file-exists? tmp) (tmpnam) tmp))))) + +;GETENV +(provide-foreign-entries '("getenv")) +(define getenv + (foreign-procedure "getenv" + (string) string)) + +(define library-vicinity + (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH") + "/usr/local/lib/slib/"))) + (lambda () library-path))) + +;FORCE-OUTPUT +(define force-output flush-output) + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-*PUT-FILE. +(define (call-with-output-string f) + (let ((outsp (open-output-string))) + (f outsp) + (let ((s (get-output-string outsp))) + (close-output-port outsp) + s))) + +(define (call-with-input-string s f) + (let* ((insp (open-input-string s)) + (res (f insp))) + (close-input-port insp) + res)) + +;CHAR-CODE-LIMIT +(define char-code-limit 256) + +;Chez's MOST-POSITIVE-FIXNUM is a thunk rather than a number +(if (procedure? most-positive-fixnum) + (set! most-positive-fixnum (most-positive-fixnum))) + +;;; Return argument +(define (identity x) x) + +(define slib:eval eval) + +(define-macro! defmacro z `(define-macro! ,@z)) + +(define (defmacro? m) (get m '*expander*)) + +(define macroexpand-1 eps-expand-once) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (if (and (symbol? a) (getprop a '*expander*)) + (macroexpand (expand-once e)) + e)) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +(define defmacro:eval slib:eval) +(define macro:eval slib:eval) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;Chez's (FORMAT f . a) corresponds to Slib's (FORMAT #f f . a) + +(define chez:format format) +(define format + (lambda (where how . args) + (let ((str (apply chez:format how args))) + (cond ((not where) str) + ((eq? where #t) (display str)) + (else (display str where)))))) + +(define slib:error + (lambda args + (let ((port (current-error-port))) + (display "Error: " port) + (for-each (lambda (x) (display x port)) args) + (error #f "")))) + +(define slib:tab #\tab) +(define slib:form-feed #\page) + +;Chez's nil variable is bound to '() rather than #f + +(define nil #f) + +(define in-vicinity string-append) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:chez:quit + (let ([arg (call-with-current-continuation (lambda (x) x))]) + (cond [(procedure? arg) arg] + [arg (exit)] + [else (exit 1)]))) + +(define slib:exit + (lambda args + (cond ((null? args) (slib:chez:quit #t)) + ((eqv? #t (car args)) (slib:chez:quit #t)) + ((eqv? #f (car args)) (slib:chez:quit #f)) + ((zero? (car args)) (slib:chez:quit #t)) + (else (slib:chez:quit #f))))) + +;;; Here for backward compatability +;Note however that ".ss" is a common Chez file suffix +(define (scheme-file-suffix) ".scm") + +;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;; suffix all the module files in SLIB have. See feature 'SOURCE. + +(define (slib:load-source f) (load (string-append f (scheme-file-suffix)))) + +;;; defmacro:load and macro:load also need the default suffix +(define defmacro:load slib:load-source) +(define macro:load slib:load-source) + +;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;; by compiling "foo.scm" if this implementation can compile files. +;;; See feature 'COMPILED. + +(define slib:load-compiled load) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) + +(slib:load (in-vicinity (library-vicinity) "require")) +;end chez.init diff --git a/cltime.scm b/cltime.scm new file mode 100644 index 0000000..248f638 --- /dev/null +++ b/cltime.scm @@ -0,0 +1,74 @@ +;;;; "cltime.scm" Common-Lisp time conversion routines. +;;; Copyright (C) 1994 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'values) +(require 'posix-time) + +(define (get-decoded-time) + (decode-universal-time (get-universal-time))) + +(define (get-universal-time) + (difftime (current-time) time:1900)) + +(define (decode-universal-time utime . tzarg) + (let* ((tz (if (null? tzarg) *timezone* (* 3600 (car tzarg)))) + (tv (time:split + (offset-time time:1900 utime) + (if (null? tzarg) time:daylight 0) + tz + (if (= tz *timezone*) (vector-ref time:tzname time:daylight) + "")))) + (values + (vector-ref tv 0) ;second [0..59] + (vector-ref tv 1) ;minute [0..59] + (vector-ref tv 2) ;hour [0..23] + (vector-ref tv 3) ;date [1..31] + (+ 1 (vector-ref tv 4)) ;month [1..12] + (+ 1900 (vector-ref tv 5)) ;year [0....] + (modulo (+ -1 (vector-ref tv 6)) 7);day-of-week [0..6] (0 is Monday) + (eqv? 1 (vector-ref tv 8)) ;daylight-saving-time? + (if (provided? 'inexact) + (inexact->exact (/ (vector-ref tv 9) 3600)) + (/ (vector-ref tv 9) 3600)) ;time-zone [-24..24] + ))) + +(define time:1900 (time:invert time:gmtime #(0 0 0 1 0 0 #f #f 0 0 "GMT"))) + +(define (encode-universal-time second minute hour date month year . tzarg) + (let* ((tz (if (null? tzarg) *timezone* + (* 3600 (car tzarg)))) + (tv (vector second + minute + hour + date + (+ -1 month) + (+ -1900 year) + #f ;ignored + #f ;ignored + (if (= tz *timezone*) time:daylight 0) + tz + (cond ((= tz *timezone*) + (vector-ref time:tzname time:daylight)) + ((zero? tz) "GMT") + (else "")) + ))) + (if (= tz *timezone*) (difftime (time:invert localtime tv) time:1900) + (difftime (offset-time (time:invert gmtime tv) tz) time:1900)))) + +(tzset) diff --git a/collect.scm b/collect.scm new file mode 100644 index 0000000..abdf209 --- /dev/null +++ b/collect.scm @@ -0,0 +1,236 @@ +;"collect.scm" Sample collection operations +; COPYRIGHT (c) Kenneth Dickey 1992 +; +; This software may be used for any purpose whatever +; without warrantee of any kind. +; AUTHOR Ken Dickey +; DATE 1992 September 1 +; LAST UPDATED 1992 September 2 +; NOTES Expository (optimizations & checks elided). +; Requires YASOS (Yet Another Scheme Object System). + +(require 'yasos) + +(define-operation (collect:collection? obj) + ;; default + (cond + ((or (list? obj) (vector? obj) (string? obj)) #t) + (else #f) +) ) + +(define (collect:empty? collection) (zero? (yasos:size collection))) + +(define-operation (collect:gen-elts ) ;; return element generator + ;; default behavior + (cond ;; see utilities, below, for generators + ((vector? ) (collect:vector-gen-elts )) + ((list? ) (collect:list-gen-elts )) + ((string? ) (collect:string-gen-elts )) + (else + (slib:error "Operation not supported: GEN-ELTS " (yasos:print obj #f))) +) ) + +(define-operation (collect:gen-keys collection) + (if (or (vector? collection) (list? collection) (string? collection)) + (let ( (max+1 (yasos:size collection)) (index 0) ) + (lambda () + (cond + ((< index max+1) + (set! index (collect:add1 index)) + (collect:sub1 index)) + (else (slib:error "no more keys in generator")) + ) ) ) + (slib:error "Operation not handled: GEN-KEYS " collection) +) ) + +(define (collect:do-elts . ) + (let ( (max+1 (yasos:size (car ))) + (generators (map collect:gen-elts )) + ) + (let loop ( (counter 0) ) + (cond + ((< counter max+1) + (apply (map (lambda (g) (g)) generators)) + (loop (collect:add1 counter)) + ) + (else 'unspecific) ; done + ) ) +) ) + +(define (collect:do-keys . ) + (let ( (max+1 (yasos:size (car ))) + (generators (map collect:gen-keys )) + ) + (let loop ( (counter 0) ) + (cond + ((< counter max+1) + (apply (map (lambda (g) (g)) generators)) + (loop (collect:add1 counter)) + ) + (else 'unspecific) ; done + ) ) +) ) + +(define (collect:map-elts . ) + (let ( (max+1 (yasos:size (car ))) + (generators (map collect:gen-elts )) + (vec (make-vector (yasos:size (car )))) + ) + (let loop ( (index 0) ) + (cond + ((< index max+1) + (vector-set! vec index (apply (map (lambda (g) (g)) generators))) + (loop (collect:add1 index)) + ) + (else vec) ; done + ) ) +) ) + +(define (collect:map-keys . ) + (let ( (max+1 (yasos:size (car ))) + (generators (map collect:gen-keys )) + (vec (make-vector (yasos:size (car )))) + ) + (let loop ( (index 0) ) + (cond + ((< index max+1) + (vector-set! vec index (apply (map (lambda (g) (g)) generators))) + (loop (collect:add1 index)) + ) + (else vec) ; done + ) ) +) ) + +(define-operation (collect:for-each-key ) + ;; default + (collect:do-keys ) ;; talk about lazy! +) + +(define-operation (collect:for-each-elt ) + (collect:do-elts ) +) + +(define (collect:reduce . ) + (let ( (max+1 (yasos:size (car ))) + (generators (map collect:gen-elts )) + ) + (let loop ( (count 0) ) + (cond + ((< count max+1) + (set! + (apply (map (lambda (g) (g)) generators))) + (loop (collect:add1 count)) + ) + (else ) + ) ) +) ) + + + +;; pred true for every elt? +(define (collect:every? . ) + (let ( (max+1 (yasos:size (car ))) + (generators (map collect:gen-elts )) + ) + (let loop ( (count 0) ) + (cond + ((< count max+1) + (if (apply (map (lambda (g) (g)) generators)) + (loop (collect:add1 count)) + #f) + ) + (else #t) + ) ) +) ) + +;; pred true for any elt? +(define (collect:any? . ) + (let ( (max+1 (yasos:size (car ))) + (generators (map collect:gen-elts )) + ) + (let loop ( (count 0) ) + (cond + ((< count max+1) + (if (apply (map (lambda (g) (g)) generators)) + #t + (loop (collect:add1 count)) + )) + (else #f) + ) ) +) ) + + +;; MISC UTILITIES + +(define (collect:add1 obj) (+ obj 1)) +(define (collect:sub1 obj) (- obj 1)) + +;; Nota Bene: list-set! is bogus for element 0 + +(define (collect:list-set! ) + + (define (set-loop last this idx) + (cond + ((zero? idx) + (set-cdr! last (cons (cdr this))) + + ) + (else (set-loop (cdr last) (cdr this) (collect:sub1 idx))) + ) ) + + ;; main + (if (zero? ) + (cons (cdr )) ;; return value + (set-loop (cdr ) (collect:sub1 ))) +) + +(add-setter list-ref collect:list-set!) ; for (setter list-ref) + + +;; generator for list elements +(define (collect:list-gen-elts ) + (lambda () + (if (null? ) + (slib:error "No more list elements in generator") + (let ( (elt (car )) ) + (set! (cdr )) + elt)) +) ) + +;; generator for vector elements +(define (collect:make-vec-gen-elts ) + (lambda (vec) + (let ( (max+1 (yasos:size vec)) + (index 0) + ) + (lambda () + (cond ((< index max+1) + (set! index (collect:add1 index)) + ( vec (collect:sub1 index)) + ) + (else #f) + ) ) + ) ) +) + +(define collect:vector-gen-elts (collect:make-vec-gen-elts vector-ref)) + +(define collect:string-gen-elts (collect:make-vec-gen-elts string-ref)) + +;;; exports: + +(define collection? collect:collection?) +(define empty? collect:empty?) +(define gen-keys collect:gen-keys) +(define gen-elts collect:gen-elts) +(define do-elts collect:do-elts) +(define do-keys collect:do-keys) +(define map-elts collect:map-elts) +(define map-keys collect:map-keys) +(define for-each-key collect:for-each-key) +(define for-each-elt collect:for-each-elt) +(define reduce collect:reduce) ; reduce is also in comlist.scm +(define every? collect:every?) +(define any? collect:any?) + +;; --- E O F "collect.oo" --- ;; diff --git a/comlist.scm b/comlist.scm new file mode 100644 index 0000000..2c243fe --- /dev/null +++ b/comlist.scm @@ -0,0 +1,326 @@ +;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme +; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; Some of these functions may be already defined in your Scheme. +;;; Comment out those definitions for functions which are already defined. + +;;;; LIST FUNCTIONS FROM COMMON LISP + +;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) +(define (comlist:make-list k . init) + (set! init (if (pair? init) (car init))) + (do ((k k (+ -1 k)) + (result '() (cons init result))) + ((<= k 0) result))) + +(define (comlist:copy-list lst) (append lst '())) + +(define (comlist:adjoin e l) (if (memq e l) l (cons e l))) + +(define (comlist:union l1 l2) + (cond ((null? l1) l2) + ((null? l2) l1) + (else (comlist:union (cdr l1) (comlist:adjoin (car l1) l2))))) + +(define (comlist:intersection l1 l2) + (cond ((null? l1) l1) + ((null? l2) l2) + ((memv (car l1) l2) (cons (car l1) (comlist:intersection (cdr l1) l2))) + (else (comlist:intersection (cdr l1) l2)))) + +(define (comlist:set-difference l1 l2) + (cond ((null? l1) l1) + ((memv (car l1) l2) (comlist:set-difference (cdr l1) l2)) + (else (cons (car l1) (comlist:set-difference (cdr l1) l2))))) + +(define (comlist:position obj lst) + (letrec ((pos (lambda (n lst) + (cond ((null? lst) #f) + ((eqv? obj (car lst)) n) + (else (pos (+ 1 n) (cdr lst))))))) + (pos 0 lst))) + +(define (comlist:reduce-init p init l) + (if (null? l) + init + (comlist:reduce-init p (p init (car l)) (cdr l)))) + +(define (comlist:reduce p l) + (cond ((null? l) l) + ((null? (cdr l)) (car l)) + (else (comlist:reduce-init p (car l) (cdr l))))) + +(define (comlist:some pred l . rest) + (cond ((null? rest) + (let mapf ((l l)) + (and (not (null? l)) + (or (pred (car l)) (mapf (cdr l)))))) + (else (let mapf ((l l) (rest rest)) + (and (not (null? l)) + (or (apply pred (car l) (map car rest)) + (mapf (cdr l) (map cdr rest)))))))) + +(define (comlist:every pred l . rest) + (cond ((null? rest) + (let mapf ((l l)) + (or (null? l) + (and (pred (car l)) (mapf (cdr l)))))) + (else (let mapf ((l l) (rest rest)) + (or (null? l) + (and (apply pred (car l) (map car rest)) + (mapf (cdr l) (map cdr rest)))))))) + +(define (comlist:notany pred . ls) (not (apply comlist:some pred ls))) + +(define (comlist:notevery pred . ls) (not (apply comlist:every pred ls))) + +(define (comlist:find-if t l) + (cond ((null? l) #f) + ((t (car l)) (car l)) + (else (comlist:find-if t (cdr l))))) + +(define (comlist:member-if t l) + (cond ((null? l) #f) + ((t (car l)) l) + (else (comlist:member-if t (cdr l))))) + +(define (comlist:remove p l) + (cond ((null? l) l) + ((eqv? p (car l)) (comlist:remove p (cdr l))) + (else (cons (car l) (comlist:remove p (cdr l)))))) + +(define (comlist:remove-if p l) + (cond ((null? l) l) + ((p (car l)) (comlist:remove-if p (cdr l))) + (else (cons (car l) (comlist:remove-if p (cdr l)))))) + +(define (comlist:remove-if-not p l) + (cond ((null? l) l) + ((p (car l)) (cons (car l) (comlist:remove-if-not p (cdr l)))) + (else (comlist:remove-if-not p (cdr l))))) + +(define comlist:nconc + (if (provided? 'rev2-procedures) append! + (lambda args + (cond ((null? args) '()) + ((null? (cdr args)) (car args)) + ((null? (car args)) (apply comlist:nconc (cdr args))) + (else + (set-cdr! (last-pair (car args)) + (apply comlist:nconc (cdr args))) + (car args)))))) + +;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) +(define (comlist:nreverse rev-it) +;;; Reverse order of elements of LIST by mutating cdrs. + (cond ((null? rev-it) rev-it) + ((not (list? rev-it)) + (slib:error "nreverse: Not a list in arg1" rev-it)) + (else (do ((reved '() rev-it) + (rev-cdr (cdr rev-it) (cdr rev-cdr)) + (rev-it rev-it rev-cdr)) + ((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it))))) + +(define (comlist:butlast lst n) + (letrec ((l (- (length lst) n)) + (bl (lambda (lst n) + (cond ((null? lst) lst) + ((positive? n) + (cons (car lst) (bl (cdr lst) (+ -1 n)))) + (else '()))))) + (bl lst (if (negative? n) + (slib:error "negative argument to butlast" n) + l)))) + +(define (comlist:nthcdr n lst) + (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst)))) + +(define (comlist:last lst n) + (comlist:nthcdr (- (length lst) n) lst)) + +;;;; CONDITIONALS + +(define (comlist:and? . args) + (cond ((null? args) #t) + ((car args) (apply comlist:and? (cdr args))) + (else #f))) + +(define (comlist:or? . args) + (cond ((null? args) #f) + ((car args) #t) + (else (apply comlist:or? (cdr args))))) + +; Checks to see if a list has any duplicates. +(define (comlist:has-duplicates? lst) + (cond ((null? lst) #f) + ((member (car lst) (cdr lst)) #t) + (else (comlist:has-duplicates? (cdr lst))))) + +(define (comlist:list* x . y) + (define (list*1 x) + (if (null? (cdr x)) + (car x) + (cons (car x) (list*1 (cdr x))))) + (if (null? y) + x + (cons x (list*1 y)))) + +(define (comlist:atom? a) + (not (pair? a))) + +(define (type-of obj) + (cond + ((null? obj) 'null) + ((boolean? obj) 'boolean) + ((char? obj) 'char) + ((number? obj) 'number) + ((string? obj) 'string) + ((symbol? obj) 'symbol) + ((input-port? obj) 'port) + ((output-port? obj) 'port) + ((procedure? obj) 'procedure) + ((eof-object? obj) 'eof-object) + ((list? obj) 'list) + ((pair? obj) 'pair) + ((and (provided? 'array) (array? obj)) 'array) + ((and (provided? 'record) (record? obj)) 'record) + ((vector? obj) 'vector) + (else '?))) + +(define (coerce obj result-type) + (define (err) (slib:error 'coerce "couldn't" obj '-> result-type)) + (define obj-type (type-of obj)) + (cond + ((eq? obj-type result-type) obj) + (else + (case obj-type + ((char) (case result-type + ((number) (char->integer obj)) + ((string) (string obj)) + ((symbol) (string->symbol (string obj))) + ((list) (list obj)) + ((vector) (vector obj)) + (else (err)))) + ((number) (case result-type + ((char) (integer->char obj)) + ((atom) obj) + ((string) (number->string obj)) + ((symbol) (string->symbol (number->string obj))) + ((list) (string->list (number->string obj))) + ((vector) (list->vector (string->list (number->string obj)))) + (else (err)))) + ((string) (case result-type + ((char) (if (= 1 (string-length obj)) (string-ref obj 0) + (err))) + ((atom) (or (string->number obj) (string->symbol obj))) + ((number) (or (string->number obj) (err))) + ((symbol) (string->symbol obj)) + ((list) (string->list obj)) + ((vector) (list->vector (string->list obj))) + (else (err)))) + ((symbol) (case result-type + ((char) (coerce (symbol->string obj) 'char)) + ((number) (coerce (symbol->string obj) 'number)) + ((string) (symbol->string obj)) + ((atom) obj) + ((list) (string->list (symbol->string obj))) + ((vector) (list->vector (string->list (symbol->string obj)))) + (else (err)))) + ((list) (case result-type + ((char) (if (and (= 1 (length obj)) + (char? (car obj))) + (car obj) + (err))) + ((number) (or (string->number (list->string obj)) (err))) + ((string) (list->string obj)) + ((symbol) (string->symbol (list->string obj))) + ((vector) (list->vector obj)) + (else (err)))) + ((vector) (case result-type + ((char) (if (and (= 1 (vector-length obj)) + (char? (vector-ref obj 0))) + (vector-ref obj 0) + (err))) + ((number) (or (string->number (coerce obj string)) (err))) + ((string) (list->string (vector->list obj))) + ((symbol) (string->symbol (coerce obj string))) + ((list) (list->vector obj)) + (else (err)))) + (else (err)))))) + +(define (comlist:delete obj list) + (let delete ((list list)) + (cond ((null? list) '()) + ((equal? obj (car list)) (delete (cdr list))) + (else + (set-cdr! list (delete (cdr list))) + list)))) + +(define (comlist:delete-if pred list) + (let delete-if ((list list)) + (cond ((null? list) '()) + ((pred (car list)) (delete-if (cdr list))) + (else + (set-cdr! list (delete-if (cdr list))) + list)))) + +(define (comlist:delete-if-not pred list) + (let delete-if ((list list)) + (cond ((null? list) '()) + ((not (pred (car list))) (delete-if (cdr list))) + (else + (set-cdr! list (delete-if (cdr list))) + list)))) + +;;; exports + +(define make-list comlist:make-list) +(define copy-list comlist:copy-list) +(define adjoin comlist:adjoin) +(define union comlist:union) +(define intersection comlist:intersection) +(define set-difference comlist:set-difference) +(define position comlist:position) +(define reduce-init comlist:reduce-init) +(define reduce comlist:reduce) ; reduce is also in collect.scm +(define some comlist:some) +(define every comlist:every) +(define notevery comlist:notevery) +(define notany comlist:notany) +(define find-if comlist:find-if) +(define member-if comlist:member-if) +(define remove comlist:remove) +(define remove-if comlist:remove-if) +(define remove-if-not comlist:remove-if-not) +(define nconc comlist:nconc) +(define nreverse comlist:nreverse) +(define butlast comlist:butlast) +(define nthcdr comlist:nthcdr) +(define last comlist:last) +(define and? comlist:and?) +(define or? comlist:or?) +(define has-duplicates? comlist:has-duplicates?) + +(define delete-if-not comlist:delete-if-not) +(define delete-if comlist:delete-if) +(define delete comlist:delete) +(define comlist:atom comlist:atom?) +(define atom comlist:atom?) +(define atom? comlist:atom?) +(define list* comlist:list*) diff --git a/comparse.scm b/comparse.scm new file mode 100644 index 0000000..add47c8 --- /dev/null +++ b/comparse.scm @@ -0,0 +1,92 @@ +;;; "comparse.scm" Break command line into arguments. +;Copyright (C) 1995 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;;; This is a simple command-line reader. It could be made fancier +;;; to handle lots of `shell' syntaxes. + +(require 'string-port) +(define (read-command . port) + (define argv '()) + (define obj "") + (define chars '()) + (define eof #f) + (define readc (lambda () (read-char port))) + (define peekc (lambda () (peek-char port))) + (define s-expression + (lambda () + (splice-arg (call-with-output-string + (lambda (p) (display (slib:eval (read port)) p)))))) + (define (backslash goto) + (readc) + (cond ((char=? #\newline (peekc)) (readc) (goto (peekc))) + (else (set! chars (cons (readc) chars)) + (build-token (peekc))))) + (define loop + (lambda (c) + (case c + ((#\\) (backslash loop)) + ((#\") (splice-arg (read port))) + ((#\( #\') (s-expression)) + ((#\#) + (do ((c (readc) (readc))) + ((or (eof-object? c) (char=? #\newline c) c)))) + ((#\; #\newline) (readc)) + (else + (cond ((eof-object? c) c) + ((char-whitespace? c) (readc) (loop (peekc))) + (else (build-token c))))))) + (define splice-arg + (lambda (arg) + (set! obj (string-append obj (list->string (reverse chars)) arg)) + (set! chars '()) + (build-token (peekc)))) + (define build-token + (lambda (c) + (case c + ((#\") (splice-arg (read port))) + ((#\() (s-expression)) + ((#\\) (backslash build-token)) + ((#\newline #\;) + (readc) + (set! argv (cons (string-append + obj (list->string (reverse chars))) + argv))) + (else + (cond ((or (eof-object? c) + (char-whitespace? c)) + (readc) + (set! argv (cons (string-append + obj (list->string (reverse chars))) + argv)) + (set! obj "") + (set! chars '()) + (loop (peekc))) + (else (set! chars (cons (readc) chars)) + (build-token (peekc)))))))) + (set! port + (cond ((null? port) (current-input-port)) + ((= 1 (length port)) (car port)) + (else + (slib:error + 'read-command-line + "Wrong Number of ARGs:" + port)))) + (let ((c (loop (peekc)))) + (cond ((and (null? argv) (eof-object? c)) c) + (else (reverse argv))))) diff --git a/dbrowse.scm b/dbrowse.scm new file mode 100644 index 0000000..aaa4635 --- /dev/null +++ b/dbrowse.scm @@ -0,0 +1,98 @@ +;;; "dbrowse.scm" relational-database-browser +; Copyright 1996 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'database-utilities) +(require 'printf) + +(define browse:db #f) + +(define (browse . args) + (define table-name '*catalog-data*) + (cond ((null? args)) + ((procedure? (car args)) + (set! browse:db (car args)) + (set! args (cdr args))) + ((string? (car args)) + (set! browse:db (open-database (car args))) + (set! args (cdr args)))) + (cond ((null? args)) + (else (set! table-name (car args)))) + (let* ((open-table (browse:db 'open-table)) + (catalog (and open-table (open-table '*catalog-data* #f)))) + (cond ((not catalog) + (slib:error 'browse "could not open catalog")) + ((eq? table-name '*catalog-data*) + (browse:display-dir '*catalog-data* catalog)) + (else + (let ((table (open-table table-name #f))) + (cond (table (browse:display-table table-name table) + (table 'close-table)) + (else (slib:error 'browse "could not open table" + table-name)))))))) + +(define (browse:display-dir table-name table) + (printf "%s Tables: +" table-name) + ((table 'for-each-row) + (lambda (row) + (printf " %s +" + (car row))))) + +(define (browse:display-table table-name table) + (let* ((width 18) + (dw (string-append "%-" (number->string width))) + (dwp (string-append "%-" (number->string width) "." + (number->string (+ -1 width)))) + (dwp-string (string-append dwp "s")) + (dwp-any (string-append dwp "a")) + (dw-integer (string-append dw "d")) + (underline (string-append (make-string (+ -1 width) #\=) " ")) + (form "")) + (printf "Table: %s +" table-name) + (for-each (lambda (name) (printf dwp-string name)) + (table 'column-names)) + (newline) + (for-each (lambda (foreign) (printf dwp-any foreign)) + (table 'column-foreigns)) + (newline) + (for-each (lambda (domain) (printf dwp-string domain)) + (table 'column-domains)) + (newline) + (for-each (lambda (type) + (case type + ((integer number uint base-id) + (set! form (string-append form dw-integer))) + ((boolean domain expression atom) + (set! form (string-append form dwp-any))) + ((string symbol) + (set! form (string-append form dwp-string))) + (else (slib:error 'browse:display-table "unknown type" type))) + (printf dwp-string type)) + (table 'column-types)) + (newline) + (set! form (string-append form " +")) + (for-each (lambda (domain) (printf underline)) + (table 'column-domains)) + (newline) + ((table 'for-each-row) + (lambda (row) + (apply printf form row))))) diff --git a/dbutil.scm b/dbutil.scm new file mode 100644 index 0000000..ffaaf9d --- /dev/null +++ b/dbutil.scm @@ -0,0 +1,222 @@ +;;; "dbutil.scm" relational-database-utilities +; Copyright 1994, 1995 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'relational-database) + +(define (db:base-type path) + 'alist-table) ; currently the only one. + +(define (dbutil:wrap-command-interface rdb) + (and rdb + (let* ((rdms:commands ((rdb 'open-table) '*commands* #f)) + (command:get + (and rdms:commands (rdms:commands 'get 'procedure)))) + (and command:get + (letrec ((wdb (lambda (command) + (let ((com (command:get command))) + (cond (com ((slib:eval com) wdb)) + (else (rdb command))))))) + (let ((init (wdb '*initialize*))) + (if (procedure? init) init wdb))))))) + +(define (dbutil:open-database! path . arg) + (let ((type (if (null? arg) (db:base-type path) (car arg)))) + (require type) + (dbutil:wrap-command-interface + (((make-relational-system (slib:eval type)) 'open-database) + path #t)))) + +(define (dbutil:open-database path . arg) + (let ((type (if (null? arg) (db:base-type path) (car arg)))) + (require type) + (dbutil:wrap-command-interface + (((make-relational-system (slib:eval type)) 'open-database) + path #f)))) + +(define (dbutil:create-database path type) + (require type) + (let ((rdb (((make-relational-system (slib:eval type)) 'create-database) + path))) + (dbutil:define-tables + rdb + '(parameter-arity + ((name symbol)) + ((predicate? expression) + (procedure expression)) + ((single (lambda (a) (and (pair? a) (null? (cdr a)))) car) + (optional + (lambda (lambda (a) (or (null? a) (and (pair? a) (null? (cdr a)))))) + identity) + (boolean + (lambda (a) (or (null? a) + (and (pair? a) (null? (cdr a)) (boolean? (car a))))) + (lambda (a) (if (null? a) #f (car a)))) + (nary (lambda (a) #t) identity) + (nary1 (lambda (a) (not (null? a))) identity)))) + (for-each (((rdb 'open-table) '*domains-data* #t) 'row:insert) + '((parameter-list *catalog-data* #f symbol #f) + (parameter-name-translation *catalog-data* #f symbol #f) + (parameter-arity parameter-arity #f symbol #f))) + (dbutil:define-tables + rdb + '(*parameter-columns* + *columns* + *columns* + ((1 #t index #f uint) + (2 #f name #f symbol) + (3 #f arity #f parameter-arity) + (4 #f domain #f domain) + (5 #f default #f expression) + (6 #f expander #f expression) + (7 #f documentation #f string))) + '(no-parameters + *parameter-columns* + *parameter-columns* + ()) + '(no-parameter-names + ((name string)) + ((parameter-index uint)) + ()) + '(*commands* + ((name symbol)) + ((parameters parameter-list) + (parameter-names parameter-name-translation) + (procedure expression) + (documentation string)) + ((domain-checker + no-parameters + no-parameter-names + (lambda (rdb) + (let* ((ro:domains ((rdb 'open-table) '*domains-data* #f)) + (ro:get-dir (ro:domains 'get 'domain-integrity-rule)) + (ro:for-tab (ro:domains 'get 'foreign-table))) + (lambda (domain) + (let ((fkname (ro:for-tab domain)) + (dir (slib:eval (ro:get-dir domain)))) + (cond (fkname (let* ((fktab ((rdb 'open-table) fkname #f)) + (p? (fktab 'get 1))) + (cond (dir (lambda (e) (and (dir e) (p? e)))) + (else p?)))) + (else dir)))))) + "return procedure to check given domain name") + + (add-domain + no-parameters + no-parameter-names + (lambda (rdb) + (((rdb 'open-table) '*domains-data* #t) 'row:insert)) + "given the row describing it, add a domain") + + (delete-domain + no-parameters + no-parameter-names + (lambda (rdb) + (((rdb 'open-table) '*domains-data* #t) 'row:remove)) + "given its name, delete a domain")))) + (dbutil:wrap-command-interface rdb))) + +(define (make-command-server rdb command-table) + (let* ((comtab ((rdb 'open-table) command-table #f)) + (names (comtab 'column-names)) + (row-ref (lambda (row name) (list-ref row (position name names)))) + (comgetrow (comtab 'row:retrieve))) + (lambda (comname command-callback) + (let* ((command:row (comgetrow comname)) + (parameter-table ((rdb 'open-table) + (row-ref command:row 'parameters) #f)) + (parameter-names + ((rdb 'open-table) (row-ref command:row 'parameter-names) #f)) + (comval ((slib:eval (row-ref command:row 'procedure)) rdb)) + (options ((parameter-table 'get* 'name))) + (positions ((parameter-table 'get* 'index))) + (arities ((parameter-table 'get* 'arity))) + (defaults (map slib:eval ((parameter-table 'get* 'default)))) + (domains ((parameter-table 'get* 'domain))) + (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id) + domains)) + (dirs (map (rdb 'domain-checker) domains)) + (aliases + (map list ((parameter-names 'get* 'name)) + (map (parameter-table 'get 'name) + ((parameter-names 'get* 'parameter-index)))))) + (command-callback comname comval options positions + arities types defaults dirs aliases))))) + +(define (dbutil:define-tables rdb . spec-list) + (define new-tables '()) + (define dom:typ (((rdb 'open-table) '*domains-data* #f) 'get 4)) + (define create-table (rdb 'create-table)) + (define open-table (rdb 'open-table)) + (define table-exists? (rdb 'table-exists?)) + (define (check-domain dname) + (cond ((dom:typ dname)) + ((member dname new-tables) + (let* ((ftab (open-table + (string->symbol + (string-append "desc:" (symbol->string dname))) + #f))) + ((((rdb 'open-table) '*domains-data* #t) 'row:insert) + (list dname dname #f + (dom:typ ((ftab 'get 'domain-name) 1)) #f)))))) + (define (define-table name prikeys slots data) + (cond + ((table-exists? name) + (let* ((tab (open-table name #t)) + (row:update (tab 'row:update))) + (for-each row:update data))) + ((and (symbol? prikeys) (eq? prikeys slots)) + (cond ((not (table-exists? slots)) + (slib:error "Table doesn't exist:" slots))) + (set! new-tables (cons name new-tables)) + (let* ((tab (create-table name slots)) + (row:insert (tab 'row:insert))) + (for-each row:insert data) + ((tab 'close-table)))) + (else + (let* ((descname + (string->symbol (string-append "desc:" (symbol->string name)))) + (tab (create-table descname)) + (row:insert (tab 'row:insert)) + (j 0)) + (set! new-tables (cons name new-tables)) + (for-each (lambda (des) + (set! j (+ 1 j)) + (check-domain (cadr des)) + (row:insert (list j #t (car des) + (if (null? (cddr des)) #f (caddr des)) + (cadr des)))) + prikeys) + (for-each (lambda (des) + (set! j (+ 1 j)) + (check-domain (cadr des)) + (row:insert (list j #f (car des) + (if (null? (cddr des)) #f (caddr des)) + (cadr des)))) + slots) + ((tab 'close-table)) + (set! tab (create-table name descname)) + (set! row:insert (tab 'row:insert)) + (for-each row:insert data) + ((tab 'close-table)))))) + (for-each (lambda (spec) (apply define-table spec)) spec-list)) + +(define create-database dbutil:create-database) +(define open-database! dbutil:open-database!) +(define open-database dbutil:open-database) +(define define-tables dbutil:define-tables) diff --git a/debug.scm b/debug.scm new file mode 100644 index 0000000..08406a9 --- /dev/null +++ b/debug.scm @@ -0,0 +1,78 @@ +;;;; "debug.scm" Utility functions for debugging in Scheme. +;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'trace) +(require 'break) + +(define (for-each-top-level-definition-in-file file proc) + (call-with-input-file + file + (lambda + (port) + (letrec + ((walk + (lambda (exp) + (cond + ((not (and (pair? exp) (list? exp)))) + ((not (symbol? (car exp)))) + (else + (case (car exp) + ((begin) (for-each walk (cdr exp))) + ((cond) (for-each + (lambda (exp) + (for-each walk + (if (list? (car exp)) exp (cdr exp)))) + (cdr exp))) + ((if) (for-each + walk + (if (list? (cadr exp)) (cdr exp) (cddr exp)))) + ((defmacro define-syntax) "should do something clever here") + ((define) + (proc exp)))))))) + (do ((form (read port) (read port))) + ((eof-object? form)) + (walk form)))))) + +(define (for-each-top-level-defined-procedure-symbol-in-file file proc) + (letrec ((get-defined-symbol + (lambda (form) + (if (pair? form) + (get-defined-symbol (car form)) + form)))) + (for-each-top-level-definition-in-file + file + (lambda (form) (let ((sym (get-defined-symbol (cadr form)))) + (cond ((procedure? (slib:eval sym)) + (proc sym)))))))) + +(define (debug:trace-all file) + (for-each-top-level-defined-procedure-symbol-in-file + file + (lambda (sym) + (slib:eval `(set! ,sym (trace:tracef ,sym ',sym)))))) + +(define trace-all debug:trace-all) + +(define (debug:break-all file) + (for-each-top-level-defined-procedure-symbol-in-file + file + (lambda (sym) + (slib:eval `(set! ,sym (break:breakf ,sym ',sym)))))) + +(define break-all debug:break-all) diff --git a/defmacex.scm b/defmacex.scm new file mode 100644 index 0000000..bdaf020 --- /dev/null +++ b/defmacex.scm @@ -0,0 +1,96 @@ +;;;"defmacex.scm" defmacro:expand* for any Scheme dialect. +;;;Copyright 1993-1994 Dorai Sitaram and Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;;expand thoroughly, not just topmost expression. While expanding +;;;subexpressions, the primitive forms quote, lambda, set!, let/*/rec, +;;;cond, case, do, quasiquote: need to be destructured properly. (if, +;;;and, or, begin: don't need special treatment.) + +(define (defmacro:iqq e depth) + (letrec + ((map1 (lambda (f x) + (if (pair? x) (cons (f (car x)) (map1 f (cdr x))) + x))) + (iqq (lambda (e depth) + (if (pair? e) + (case (car e) + ((quasiquote) (list (car e) (iqq (cadr e) (+ 1 depth)))) + ((unquote unquote-splicing) + (list (car e) (if (= 1 depth) + (defmacro:expand* (cadr e)) + (iqq (cadr e) (+ -1 depth))))) + (else (map1 (lambda (e) (iqq e depth)) e))) + e)))) + (iqq e depth))) + +(define (defmacro:expand* e) + (if (pair? e) + (let* ((c (macroexpand-1 e))) + (if (not (eq? e c)) + (defmacro:expand* c) + (case (car e) + ((quote) e) + ((quasiquote) (defmacro:iqq e 0)) + ((lambda define set!) + (cons (car e) (cons (cadr e) (map defmacro:expand* (cddr e))))) + ((let) + (let ((b (cadr e))) + (if (symbol? b) ;named let + `(let ,b + ,(map (lambda (vv) + `(,(car vv) + ,(defmacro:expand* (cadr vv)))) + (caddr e)) + ,@(map defmacro:expand* + (cdddr e))) + `(let + ,(map (lambda (vv) + `(,(car vv) + ,(defmacro:expand* (cadr vv)))) + b) + ,@(map defmacro:expand* + (cddr e)))))) + ((let* letrec) + `(,(car e) ,(map (lambda (vv) + `(,(car vv) + ,(defmacro:expand* (cadr vv)))) + (cadr e)) + ,@(map defmacro:expand* (cddr e)))) + ((cond) + `(cond + ,@(map (lambda (c) + (map defmacro:expand* c)) + (cdr e)))) + ((case) + `(case ,(defmacro:expand* (cadr e)) + ,@(map (lambda (c) + `(,(car c) + ,@(map defmacro:expand* (cdr c)))) + (cddr e)))) + ((do) + `(do ,(map + (lambda (initsteps) + `(,(car initsteps) + ,@(map defmacro:expand* + (cdr initsteps)))) + (cadr e)) + ,(map defmacro:expand* (caddr e)) + ,@(map defmacro:expand* (cdddr e)))) + (else (map defmacro:expand* e))))) + e)) diff --git a/dwindtst.scm b/dwindtst.scm new file mode 100644 index 0000000..8d64800 --- /dev/null +++ b/dwindtst.scm @@ -0,0 +1,80 @@ +;;;; "dwindtst.scm", routines for characterizing dynamic-wind. +;Copyright (C) 1992 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'dynamic-wind) + +(define (dwtest n) + (define cont #f) + (display "testing escape from thunk") (display n) (newline) + (display "visiting:") (newline) + (call-with-current-continuation + (lambda (x) (set! cont x))) + (if n + (dynamic-wind + (lambda () + (display "thunk1") (newline) + (if (eqv? n 1) (let ((ntmp n)) + (set! n #f) + (cont ntmp)))) + (lambda () + (display "thunk2") (newline) + (if (eqv? n 2) (let ((ntmp n)) + (set! n #f) + (cont ntmp)))) + (lambda () + (display "thunk3") (newline) + (if (eqv? n 3) (let ((ntmp n)) + (set! n #f) + (cont ntmp))))))) +(define (dwctest n) + (define cont #f) + (define ccont #f) + (display "creating continuation thunk") (newline) + (display "visiting:") (newline) + (call-with-current-continuation + (lambda (x) (set! cont x))) + (if n (set! n (- n))) + (if n + (dynamic-wind + (lambda () + (display "thunk1") (newline) + (if (eqv? n 1) (let ((ntmp n)) + (set! n #f) + (cont ntmp)))) + (lambda () + (call-with-current-continuation + (lambda (x) (set! ccont x))) + (display "thunk2") (newline) + (if (eqv? n 2) (let ((ntmp n)) + (set! n #f) + (cont ntmp)))) + (lambda () + (display "thunk3") (newline) + (if (eqv? n 3) (let ((ntmp n)) + (set! n #f) + (cont ntmp)))))) + (cond + (n + (set! n (- n)) + (display "testing escape from continuation thunk") (display n) (newline) + (display "visiting:") (newline) + (ccont #f)))) + +(dwtest 1) (dwtest 2) (dwtest 3) +(dwctest 1) (dwctest 2) (dwctest 3) diff --git a/dynamic.scm b/dynamic.scm new file mode 100644 index 0000000..937f93e --- /dev/null +++ b/dynamic.scm @@ -0,0 +1,75 @@ +; "dynamic.scm", DYNAMIC data type for Scheme +; Copyright 1992 Andrew Wilcox. +; +; You may freely copy, redistribute and modify this package. + +(require 'record) +(require 'dynamic-wind) + +(define dynamic-environment-rtd + (make-record-type "dynamic environment" '(dynamic value parent))) +(define make-dynamic-environment + (record-constructor dynamic-environment-rtd)) +(define dynamic-environment:dynamic + (record-accessor dynamic-environment-rtd 'dynamic)) +(define dynamic-environment:value + (record-accessor dynamic-environment-rtd 'value)) +(define dynamic-environment:set-value! + (record-modifier dynamic-environment-rtd 'value)) +(define dynamic-environment:parent + (record-accessor dynamic-environment-rtd 'parent)) + +(define *current-dynamic-environment* #f) +(define (extend-current-dynamic-environment dynamic obj) + (set! *current-dynamic-environment* + (make-dynamic-environment dynamic obj + *current-dynamic-environment*))) + +(define dynamic-rtd (make-record-type "dynamic" '())) +(define make-dynamic + (let ((dynamic-constructor (record-constructor dynamic-rtd))) + (lambda (obj) + (let ((dynamic (dynamic-constructor))) + (extend-current-dynamic-environment dynamic obj) + dynamic)))) + +(define dynamic? (record-predicate dynamic-rtd)) +(define (guarantee-dynamic dynamic) + (or (dynamic? dynamic) + (slib:error "Not a dynamic" dynamic))) + +(define dynamic:errmsg + "No value defined for this dynamic in the current dynamic environment") + +(define (dynamic-ref dynamic) + (guarantee-dynamic dynamic) + (let loop ((env *current-dynamic-environment*)) + (cond ((not env) + (slib:error dynamic:errmsg dynamic)) + ((eq? (dynamic-environment:dynamic env) dynamic) + (dynamic-environment:value env)) + (else + (loop (dynamic-environment:parent env)))))) + +(define (dynamic-set! dynamic obj) + (guarantee-dynamic dynamic) + (let loop ((env *current-dynamic-environment*)) + (cond ((not env) + (slib:error dynamic:errmsg dynamic)) + ((eq? (dynamic-environment:dynamic env) dynamic) + (dynamic-environment:set-value! env obj)) + (else + (loop (dynamic-environment:parent env)))))) + +(define (call-with-dynamic-binding dynamic obj thunk) + (let ((out-thunk-env #f) + (in-thunk-env (make-dynamic-environment + dynamic obj + *current-dynamic-environment*))) + (dynamic-wind (lambda () + (set! out-thunk-env *current-dynamic-environment*) + (set! *current-dynamic-environment* in-thunk-env)) + thunk + (lambda () + (set! in-thunk-env *current-dynamic-environment*) + (set! *current-dynamic-environment* out-thunk-env))))) diff --git a/dynwind.scm b/dynwind.scm new file mode 100644 index 0000000..9212422 --- /dev/null +++ b/dynwind.scm @@ -0,0 +1,74 @@ +; "dynwind.scm", wind-unwind-protect for Scheme +; Copyright (c) 1992, 1993 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;This facility is a generalization of Common Lisp `unwind-protect', +;designed to take into account the fact that continuations produced by +;CALL-WITH-CURRENT-CONTINUATION may be reentered. + +; (dynamic-wind ) procedure + +;The arguments , , and must all be procedures +;of no arguments (thunks). + +;DYNAMIC-WIND calls , , and then . The value +;returned by is returned as the result of DYNAMIC-WIND. +; is also called just before control leaves the dynamic +;context of by calling a continuation created outside that +;context. Furthermore, is called before reentering the +;dynamic context of by calling a continuation created inside +;that context. (Control is inside the context of if +;is on the current return stack). + +;;;WARNING: This code has no provision for dealing with errors or +;;;interrupts. If an error or interrupt occurs while using +;;;dynamic-wind, the dynamic environment will be that in effect at the +;;;time of the error or interrupt. + +(define dynamic:winds '()) + +(define (dynamic-wind ) + () + (set! dynamic:winds (cons (cons ) dynamic:winds)) + (let ((ans ())) + (set! dynamic:winds (cdr dynamic:winds)) + () + ans)) + +(define call-with-current-continuation + (let ((oldcc call-with-current-continuation)) + (lambda (proc) + (let ((winds dynamic:winds)) + (oldcc + (lambda (cont) + (proc (lambda (c2) + (dynamic:do-winds winds (- (length dynamic:winds) + (length winds))) + (cont c2))))))))) + +(define (dynamic:do-winds to delta) + (cond ((eq? dynamic:winds to)) + ((negative? delta) + (dynamic:do-winds (cdr to) (+ 1 delta)) + ((caar to)) + (set! dynamic:winds to)) + (else + (let ((from (cdar dynamic:winds))) + (set! dynamic:winds (cdr dynamic:winds)) + (from) + (dynamic:do-winds to (+ -1 delta)))))) diff --git a/elk.init b/elk.init new file mode 100644 index 0000000..f6dded0 --- /dev/null +++ b/elk.init @@ -0,0 +1,281 @@ +;;;"elk.init" Initialisation file for SLIB for ELK 2.1 -*- Scheme -*- +;;; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +; No guarantees are given about the correctness of any of the +; choices made below. Only enough work was done to get the require +; mechanism to work correctly. +; +; Stephen J. Bevan 19920912 modified by Mike +; Sperber to work correctly with statically-linked Elk and slib1d. Be +; sure to change the library vicinities according to your local +; configuration. If you're running MS-DOS (which is possible since +; 2.1), you probably have to change this file to make everything work +; correctly. + +;;; (software-type) should be set to the generic operating system type. +;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. + +(define (software-type) 'UNIX) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. + +(define (scheme-implementation-type) 'Elk) + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "?2.1") + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. + +(define (implementation-vicinity) + (case (software-type) + ((UNIX) "/usr/local/lib/elk-2.1/scm/") + ((VMS) "scheme$src:") + ((MS-DOS) "C:\\scheme\\"))) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +(define library-vicinity + (let ((library-path + (or (getenv "SCHEME_LIBRARY_PATH") + ;; Uses this path if SCHEME_LIBRARY_PATH is not defined. + (case (software-type) + ((UNIX) "/usr/local/lib/slib/") + ((VMS) "lib$scheme:") + ((MS-DOS) "C:\\SLIB\\") + (else ""))))) + (lambda () library-path))) + +;;; *features* should be set to a list of symbols describing features +;;; of this implementation. Suggestions for features are: + +(define *features* + '( + source ;can load scheme source files + ;(slib:load-source "filename") + compiled ;can load compiled files + ;(slib:load-compiled "filename") + rev4-report + ieee-p1178 + sicp + rev4-optional-procedures + rev3-procedures + rev2-procedures + multiarg/and- + multiarg-apply + delay + transcript + full-continuation + sort + format + system + getenv + program-arguments + string-port + )) + +;------------ + +(define program-arguments + (lambda () + (cons "undefined-program-name" (command-line-args)))) + +; EXACT? appears to always return #f which isn't very useful. +; Approximating it with INTEGER? at least means that some +; of the code in the library will work correctly + +(define exact? integer?) ; WARNING: redefining EXACT? + +(define (inexact? arg) + (not (exact? arg))) + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam + (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (let ((tmp (string-append "slib_" (number->string cntr)))) + (if (file-exists? tmp) (tmpnam) tmp))))) + +(require 'unix) + +; Pull in GENTENV and SYSTEM + +;;; (FILE-EXISTS? ) already here. + +;;; (DELETE-FILE ) +(define (delete-file f) (system (string-append "rm " f))) + +;------------ + +;;; (OUTPUT-PORT-WIDTH ) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT ) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +;;; is already defined in Elk 2.1 + +;;; FORCE-OUTPUT flushes any pending output on optional arg output port +;;; use this definition if your system doesn't have such a procedure. +(define force-output flush-output-port) + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-*PUT-FILE. +(define (call-with-output-string f) + (let ((outsp (open-output-string))) + (f outsp) + (let ((s (get-output-string outsp))) + (close-output-port outsp) + s))) + +(define (call-with-input-string s f) + (let* ((insp (open-input-string s)) + (res (f insp))) + (close-input-port insp) + res)) + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +(define char-code-limit 256) + +;;; MOST-POSITIVE-FIXNUM is used in modular.scm +(define most-positive-fixnum 8388608) ; 23 bit integers ? + +;;; Return argument +(define (identity x) x) + +;;; If your implementation provides eval SLIB:EVAL is single argument +;;; eval using the top-level (user) environment. +(define slib:eval eval) + +(define *macros* '()) +(define (defmacro? m) (and (assq m *macros*) #t)) + +(define-macro (defmacro key pattern . body) + `(begin + (define-macro ,(cons key pattern) ,@body) + (set! *macros* (cons (cons ',key (lambda ,pattern ,@body)) *macros*)))) + +(define (macroexpand-1 e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) (set! a (assq a *macros*)) + (if a (apply (cdr a) (cdr e)) e)) + (else e))) + e)) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) + (set! a (assq a *macros*)) + (if a (macroexpand (apply (cdr a) (cdr e))) e)) + (else e))) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +(define defmacro:eval slib:eval) +(define defmacro:load load) +;;; If your implementation provides R4RS macros: +;(define macro:eval slib:eval) +;(define macro:load load) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;;; define an error procedure for the library +(define slib:error error) + +;;; define these as appropriate for your system. +(define slib:tab #\tab) +(define slib:form-feed #\formfeed) + +;;; Define these if your implementation's syntax can support it and if +;;; they are not already defined. + +;(define (1+ n) (+ n 1)) +;(define (-1+ n) (+ n -1)) +;(define 1- -1+) + +(define in-vicinity string-append) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:exit + (lambda args + (exit (cond ((null? args) 0) + ((eqv? #t (car args)) 0) + ((and (number? (car args)) (integer? (car args))) (car args)) + (else 1))))) + +;;; Here for backward compatability +(define scheme-file-suffix + (let ((suffix (case (software-type) + ((NOSVE) "_scm") + (else ".scm")))) + (lambda () suffix))) + +;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;; suffix all the module files in SLIB have. See feature 'SOURCE. + +; Modify the already modified _load_ so that it copes with +; environments correctly. The change involves using +; _(global-environment)_ if none is explicitly specified. +; If this is not done, definitions in files loaded by other files will +; not be loaded in the correct environment. + +(define slib:load-source + (let ((primitive-load load)) + (lambda ( . rest) + (let ((env (if (null? rest) (list (global-environment)) rest))) + (apply primitive-load env))))) + +;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;; by compiling "foo.scm" if this implementation can compile files. +;;; See feature 'COMPILED. + +(define slib:load-compiled + (let ((primitive-load load)) + (lambda ( . rest) + (apply primitive-load (string->symbol (string-append name ".o")) rest)))) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) ;WARNING: redefining LOAD + +(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/factor.scm b/factor.scm new file mode 100644 index 0000000..a5d3e8c --- /dev/null +++ b/factor.scm @@ -0,0 +1,149 @@ +;;;; "factor.scm", prime test and factorization for Scheme +;;; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'random) +(require 'modular) + +;;; (modulo p 16) is because we care only about the low order bits. +;;; The odd? tests are inline of (expt -1 ...) + +(define (prime:jacobi-symbol p q) + (cond ((zero? p) 0) + ((= 1 p) 1) + ((odd? p) + (if (odd? (quotient (* (- (modulo p 16) 1) (- q 1)) 4)) + (- (prime:jacobi-symbol (modulo q p) p)) + (prime:jacobi-symbol (modulo q p) p))) + (else + (let ((qq (modulo q 16))) + (if (odd? (quotient (- (* qq qq) 1) 8)) + (- (prime:jacobi-symbol (quotient p 2) q)) + (prime:jacobi-symbol (quotient p 2) q)))))) + +;;;; Solovay-Strassen Prime Test +;;; if n is prime, then J(a,n) is congruent mod n to a**((n-1)/2) + +;;; See: +;;; Robert Solovay and Volker Strassen, +;;; "A Fast Monte-Carlo Test for Primality," +;;; SIAM Journal on Computing, 1977, pp 84-85. + +;;; checks if n is prime. Returns #f if not prime. #t if (probably) prime. +;;; probability of a mistake = (expt 2 (- prime:trials)) +;;; choosing prime:trials=30 should be enough +(define prime:trials 30) +;;; prime:product is a product of small primes. +(define prime:product + (let ((p 210)) + (for-each (lambda (s) (set! p (or (string->number s) p))) + '("2310" "30030" "510510" "9699690" "223092870" + "6469693230" "200560490130")) + p)) + +(define (prime:prime? n) + (set! n (abs n)) + (cond ((<= n 36) (and (memv n '(2 3 5 7 11 13 17 19 23 29 31)) #t)) + ((= 1 (gcd n prime:product)) + (do ((i prime:trials (- i 1)) + (a (+ 1 (random (- n 1))) (+ 1 (random (- n 1))))) + ((not (and (positive? i) + (= (gcd a n) 1) + (= (modulo (prime:jacobi-symbol a n) n) + (modular:expt n a (quotient (- n 1) 2))))) + (if (positive? i) #f #t)))) + (else #f))) + +;;;;Lankinen's recursive factoring algorithm: +;From: ld231782@longs.LANCE.ColoState.EDU (L. Detweiler) + +; | undefined if n<0, +; | (u,v) if n=0, +;Let f(u,v,b,n) := | [otherwise] +; | f(u+b,v,2b,(n-v)/2) or f(u,v+b,2b,(n-u)/2) if n odd +; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even + +;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m. + +;It may be illuminating to consider the relation of the Lankinen function in +;a `computational hierarchy' of other factoring functions.* Assumptions are +;made herein on the basis of conventional digital (binary) computers. Also, +;complexity orders are given for the worst case scenarios (when the number to +;be factored is prime). However, all algorithms would probably perform to +;the same constant multiple of the given orders for complete composite +;factorizations. + +;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and +; O(n*log2(n)) in space. +;Pf: It works with all prime factors less than n (about ln(n)/n by the prime +; number thm), requiring an array of size proportional to n with log2(n) +; space for each entry. + +;Thm: `Odd factors' is O((sqrt(n)/2)*log2(n)) in time and O(log2(n)) in +; space. +;Pf: It tests all odd factors less than the square root of n (about +; sqrt(n)/2), with log2(n) time for each division. It requires only +; log2(n) space for the number and divisors. + +;Thm: Lankinen's algorithm is O(sqrt(n)/2) in time and O((sqrt(n)/2)*log2(n)) +; in space. +;Pf: The algorithm is easily modified to seach only for factors pstring so the case of the printed +;; symbols is implementation dependent. format:symbol-case-conv is a +;; one arg closure which is either #f (no conversion), string-upcase!, +;; string-downcase! or string-capitalize!. + +(define format:iobj-case-conv #f) +;; As format:symbol-case-conv but applies for the representation of +;; implementation internal objects. + +(define format:expch #\E) +;; The character prefixing the exponent value in ~e printing. + +(define format:floats (provided? 'inexact)) +;; Detects if the scheme system implements flonums (see at eof). + +(define format:complex-numbers (provided? 'complex)) +;; Detects if the scheme system implements complex numbers. + +(define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0))) +;; Detects if number->string adds a radix prefix. + +(define format:ascii-non-printable-charnames + '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" + "bs" "ht" "nl" "vt" "np" "cr" "so" "si" + "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb" + "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space")) + +;;; End of configuration ---------------------------------------------------- + +(define format:version "3.0") +(define format:port #f) ; curr. format output port +(define format:output-col 0) ; curr. format output tty column +(define format:flush-output #f) ; flush output at end of formatting +(define format:case-conversion #f) +(define format:error-continuation #f) +(define format:args #f) +(define format:pos 0) ; curr. format string parsing position +(define format:arg-pos 0) ; curr. format argument position + ; this is global for error presentation + +; format string and char output routines on format:port + +(define (format:out-str str) + (if format:case-conversion + (display (format:case-conversion str) format:port) + (display str format:port)) + (set! format:output-col + (+ format:output-col (string-length str)))) + +(define (format:out-char ch) + (if format:case-conversion + (display (format:case-conversion (string ch)) format:port) + (write-char ch format:port)) + (set! format:output-col + (if (char=? ch #\newline) + 0 + (+ format:output-col 1)))) + +;(define (format:out-substr str i n) ; this allocates a new string +; (display (substring str i n) format:port) +; (set! format:output-col (+ format:output-col n))) + +(define (format:out-substr str i n) + (do ((k i (+ k 1))) + ((= k n)) + (write-char (string-ref str k) format:port)) + (set! format:output-col (+ format:output-col n))) + +;(define (format:out-fill n ch) ; this allocates a new string +; (format:out-str (make-string n ch))) + +(define (format:out-fill n ch) + (do ((i 0 (+ i 1))) + ((= i n)) + (write-char ch format:port)) + (set! format:output-col (+ format:output-col n))) + +; format's user error handler + +(define (format:error . args) ; never returns! + (let ((error-continuation format:error-continuation) + (format-args format:args) + (port (current-error-port))) + (set! format:error format:intern-error) + (if (and (>= (length format:args) 2) + (string? (cadr format:args))) + (let ((format-string (cadr format-args))) + (if (not (zero? format:arg-pos)) + (set! format:arg-pos (- format:arg-pos 1))) + (format port "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~ + ~{~a ~}===>~{~a ~})~% " + (car format:args) + (substring format-string 0 format:pos) + (substring format-string format:pos + (string-length format-string)) + (list-head (cddr format:args) format:arg-pos) + (list-tail (cddr format:args) format:arg-pos))) + (format port + "~%FORMAT: error with call: (format~{ ~a~})~% " + format:args)) + (apply format port args) + (newline port) + (set! format:error format:error-save) + (set! format:error-continuation error-continuation) + (format:abort) + (format:intern-error "format:abort does not jump to toplevel!"))) + +(define format:error-save format:error) + +(define (format:intern-error . args) ;if something goes wrong in format:error + (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline) + (display " format args: ") (write format:args) (newline) + (display " error args: ") (write args) (newline) + (set! format:error format:error-save) + (format:abort)) + +(define (format:format . args) ; the formatter entry + (set! format:args args) + (set! format:arg-pos 0) + (set! format:pos 0) + (if (< (length args) 1) + (format:error "not enough arguments")) + (let ((destination (car args)) + (arglist (cdr args))) + (cond + ((or (and (boolean? destination) ; port output + destination) + (output-port? destination) + (number? destination)) + (format:out (cond + ((boolean? destination) (current-output-port)) + ((output-port? destination) destination) + ((number? destination) (current-error-port))) + (car arglist) (cdr arglist))) + ((and (boolean? destination) ; string output + (not destination)) + (call-with-output-string + (lambda (port) (format:out port (car arglist) (cdr arglist))))) + ((string? destination) ; dest. is format string (Scheme->C) + (call-with-output-string + (lambda (port) + (format:out port destination arglist)))) + (else + (format:error "illegal destination `~a'" destination))))) + +(define (format:out port fmt args) ; the output handler for a port + (set! format:port port) ; global port for output routines + (set! format:case-conversion #f) ; modifier case conversion procedure + (set! format:flush-output #f) ; ~! reset + (let ((arg-pos (format:format-work fmt args)) + (arg-len (length args))) + (cond + ((< arg-pos arg-len) + (set! format:arg-pos (+ arg-pos 1)) + (set! format:pos (string-length fmt)) + (format:error "~a superfluous argument~:p" (- arg-len arg-pos))) + ((> arg-pos arg-len) + (set! format:arg-pos (+ arg-len 1)) + (display format:arg-pos) + (format:error "~a missing argument~:p" (- arg-pos arg-len))) + (else + (if format:flush-output (force-output port)) + #t)))) + +(define format:parameter-characters + '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\')) + +(define (format:format-work format-string arglist) ; does the formatting work + (letrec + ((format-string-len (string-length format-string)) + (arg-pos 0) ; argument position in arglist + (arg-len (length arglist)) ; number of arguments + (modifier #f) ; 'colon | 'at | 'colon-at | #f + (params '()) ; directive parameter list + (param-value-found #f) ; a directive parameter value found + (conditional-nest 0) ; conditional nesting level + (clause-pos 0) ; last cond. clause beginning char pos + (clause-default #f) ; conditional default clause string + (clauses '()) ; conditional clause string list + (conditional-type #f) ; reflects the contional modifiers + (conditional-arg #f) ; argument to apply the conditional + (iteration-nest 0) ; iteration nesting level + (iteration-pos 0) ; iteration string beginning char pos + (iteration-type #f) ; reflects the iteration modifiers + (max-iterations #f) ; maximum number of iterations + (recursive-pos-save format:pos) + + (next-char ; gets the next char from format-string + (lambda () + (let ((ch (peek-next-char))) + (set! format:pos (+ 1 format:pos)) + ch))) + + (peek-next-char + (lambda () + (if (>= format:pos format-string-len) + (format:error "illegal format string") + (string-ref format-string format:pos)))) + + (one-positive-integer? + (lambda (params) + (cond + ((null? params) #f) + ((and (integer? (car params)) + (>= (car params) 0) + (= (length params) 1)) #t) + (else (format:error "one positive integer parameter expected"))))) + + (next-arg + (lambda () + (if (>= arg-pos arg-len) + (begin + (set! format:arg-pos (+ arg-len 1)) + (format:error "missing argument(s)"))) + (add-arg-pos 1) + (list-ref arglist (- arg-pos 1)))) + + (prev-arg + (lambda () + (add-arg-pos -1) + (if (negative? arg-pos) + (format:error "missing backward argument(s)")) + (list-ref arglist arg-pos))) + + (rest-args + (lambda () + (let loop ((l arglist) (k arg-pos)) ; list-tail definition + (if (= k 0) l (loop (cdr l) (- k 1)))))) + + (add-arg-pos + (lambda (n) + (set! arg-pos (+ n arg-pos)) + (set! format:arg-pos arg-pos))) + + (anychar-dispatch ; dispatches the format-string + (lambda () + (if (>= format:pos format-string-len) + arg-pos ; used for ~? continuance + (let ((char (next-char))) + (cond + ((char=? char #\~) + (set! modifier #f) + (set! params '()) + (set! param-value-found #f) + (tilde-dispatch)) + (else + (if (and (zero? conditional-nest) + (zero? iteration-nest)) + (format:out-char char)) + (anychar-dispatch))))))) + + (tilde-dispatch + (lambda () + (cond + ((>= format:pos format-string-len) + (format:out-str "~") ; tilde at end of string is just output + arg-pos) ; used for ~? continuance + ((and (or (zero? conditional-nest) + (memv (peek-next-char) ; find conditional directives + (append '(#\[ #\] #\; #\: #\@ #\^) + format:parameter-characters))) + (or (zero? iteration-nest) + (memv (peek-next-char) ; find iteration directives + (append '(#\{ #\} #\: #\@ #\^) + format:parameter-characters)))) + (case (char-upcase (next-char)) + + ;; format directives + + ((#\A) ; Any -- for humans + (set! format:read-proof (memq modifier '(colon colon-at))) + (format:out-obj-padded (memq modifier '(at colon-at)) + (next-arg) #f params) + (anychar-dispatch)) + ((#\S) ; Slashified -- for parsers + (set! format:read-proof (memq modifier '(colon colon-at))) + (format:out-obj-padded (memq modifier '(at colon-at)) + (next-arg) #t params) + (anychar-dispatch)) + ((#\D) ; Decimal + (format:out-num-padded modifier (next-arg) params 10) + (anychar-dispatch)) + ((#\X) ; Hexadecimal + (format:out-num-padded modifier (next-arg) params 16) + (anychar-dispatch)) + ((#\O) ; Octal + (format:out-num-padded modifier (next-arg) params 8) + (anychar-dispatch)) + ((#\B) ; Binary + (format:out-num-padded modifier (next-arg) params 2) + (anychar-dispatch)) + ((#\R) + (if (null? params) + (format:out-obj-padded ; Roman, cardinal, ordinal numerals + #f + ((case modifier + ((at) format:num->roman) + ((colon-at) format:num->old-roman) + ((colon) format:num->ordinal) + (else format:num->cardinal)) + (next-arg)) + #f params) + (format:out-num-padded ; any Radix + modifier (next-arg) (cdr params) (car params))) + (anychar-dispatch)) + ((#\F) ; Fixed-format floating-point + (if format:floats + (format:out-fixed modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\E) ; Exponential floating-point + (if format:floats + (format:out-expon modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\G) ; General floating-point + (if format:floats + (format:out-general modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\$) ; Dollars floating-point + (if format:floats + (format:out-dollar modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\I) ; Complex numbers + (if (not format:complex-numbers) + (format:error + "complex numbers not supported by this scheme system")) + (let ((z (next-arg))) + (if (not (complex? z)) + (format:error "argument not a complex number")) + (format:out-fixed modifier (real-part z) params) + (format:out-fixed 'at (imag-part z) params) + (format:out-char #\i)) + (anychar-dispatch)) + ((#\C) ; Character + (let ((ch (if (one-positive-integer? params) + (integer->char (car params)) + (next-arg)))) + (if (not (char? ch)) (format:error "~~c expects a character")) + (case modifier + ((at) + (format:out-str (format:char->str ch))) + ((colon) + (let ((c (char->integer ch))) + (if (< c 0) + (set! c (+ c 256))) ; compensate complement impl. + (cond + ((< c #x20) ; assumes that control chars are < #x20 + (format:out-char #\^) + (format:out-char + (integer->char (+ c #x40)))) + ((>= c #x7f) + (format:out-str "#\\") + (format:out-str + (if format:radix-pref + (let ((s (number->string c 8))) + (substring s 2 (string-length s))) + (number->string c 8)))) + (else + (format:out-char ch))))) + (else (format:out-char ch)))) + (anychar-dispatch)) + ((#\P) ; Plural + (if (memq modifier '(colon colon-at)) + (prev-arg)) + (let ((arg (next-arg))) + (if (not (number? arg)) + (format:error "~~p expects a number argument")) + (if (= arg 1) + (if (memq modifier '(at colon-at)) + (format:out-char #\y)) + (if (memq modifier '(at colon-at)) + (format:out-str "ies") + (format:out-char #\s)))) + (anychar-dispatch)) + ((#\~) ; Tilde + (if (one-positive-integer? params) + (format:out-fill (car params) #\~) + (format:out-char #\~)) + (anychar-dispatch)) + ((#\%) ; Newline + (if (one-positive-integer? params) + (format:out-fill (car params) #\newline) + (format:out-char #\newline)) + (set! format:output-col 0) + (anychar-dispatch)) + ((#\&) ; Fresh line + (if (one-positive-integer? params) + (begin + (if (> (car params) 0) + (format:out-fill (- (car params) + (if (> format:output-col 0) 0 1)) + #\newline)) + (set! format:output-col 0)) + (if (> format:output-col 0) + (format:out-char #\newline))) + (anychar-dispatch)) + ((#\_) ; Space character + (if (one-positive-integer? params) + (format:out-fill (car params) #\space) + (format:out-char #\space)) + (anychar-dispatch)) + ((#\/) ; Tabulator character + (if (one-positive-integer? params) + (format:out-fill (car params) slib:tab) + (format:out-char slib:tab)) + (anychar-dispatch)) + ((#\|) ; Page seperator + (if (one-positive-integer? params) + (format:out-str (car params) slib:form-feed) + (format:out-char slib:form-feed)) + (set! format:output-col 0) + (anychar-dispatch)) + ((#\T) ; Tabulate + (format:tabulate modifier params) + (anychar-dispatch)) + ((#\Y) ; Pretty-print + (require 'pretty-print) + (pretty-print (next-arg) format:port) + (set! format:output-col 0) + (anychar-dispatch)) + ((#\? #\K) ; Indirection (is "~K" in T-Scheme) + (cond + ((memq modifier '(colon colon-at)) + (format:error "illegal modifier in ~~?")) + ((eq? modifier 'at) + (let* ((frmt (next-arg)) + (args (rest-args))) + (add-arg-pos (format:format-work frmt args)))) + (else + (let* ((frmt (next-arg)) + (args (next-arg))) + (format:format-work frmt args)))) + (anychar-dispatch)) + ((#\!) ; Flush output + (set! format:flush-output #t) + (anychar-dispatch)) + ((#\newline) ; Continuation lines + (if (eq? modifier 'at) + (format:out-char #\newline)) + (if (< format:pos format-string-len) + (do ((ch (peek-next-char) (peek-next-char))) + ((or (not (char-whitespace? ch)) + (= format:pos (- format-string-len 1)))) + (if (eq? modifier 'colon) + (format:out-char (next-char)) + (next-char)))) + (anychar-dispatch)) + ((#\*) ; Argument jumping + (case modifier + ((colon) ; jump backwards + (if (one-positive-integer? params) + (do ((i 0 (+ i 1))) + ((= i (car params))) + (prev-arg)) + (prev-arg))) + ((at) ; jump absolute + (set! arg-pos (if (one-positive-integer? params) + (car params) 0))) + ((colon-at) + (format:error "illegal modifier `:@' in ~~* directive")) + (else ; jump forward + (if (one-positive-integer? params) + (do ((i 0 (+ i 1))) + ((= i (car params))) + (next-arg)) + (next-arg)))) + (anychar-dispatch)) + ((#\() ; Case conversion begin + (set! format:case-conversion + (case modifier + ((at) string-capitalize-first) + ((colon) string-capitalize) + ((colon-at) string-upcase) + (else string-downcase))) + (anychar-dispatch)) + ((#\)) ; Case conversion end + (if (not format:case-conversion) + (format:error "missing ~~(")) + (set! format:case-conversion #f) + (anychar-dispatch)) + ((#\[) ; Conditional begin + (set! conditional-nest (+ conditional-nest 1)) + (cond + ((= conditional-nest 1) + (set! clause-pos format:pos) + (set! clause-default #f) + (set! clauses '()) + (set! conditional-type + (case modifier + ((at) 'if-then) + ((colon) 'if-else-then) + ((colon-at) (format:error "illegal modifier in ~~[")) + (else 'num-case))) + (set! conditional-arg + (if (one-positive-integer? params) + (car params) + (next-arg))))) + (anychar-dispatch)) + ((#\;) ; Conditional separator + (if (zero? conditional-nest) + (format:error "~~; not in ~~[~~] conditional")) + (if (not (null? params)) + (format:error "no parameter allowed in ~~;")) + (if (= conditional-nest 1) + (let ((clause-str + (cond + ((eq? modifier 'colon) + (set! clause-default #t) + (substring format-string clause-pos + (- format:pos 3))) + ((memq modifier '(at colon-at)) + (format:error "illegal modifier in ~~;")) + (else + (substring format-string clause-pos + (- format:pos 2)))))) + (set! clauses (append clauses (list clause-str))) + (set! clause-pos format:pos))) + (anychar-dispatch)) + ((#\]) ; Conditional end + (if (zero? conditional-nest) (format:error "missing ~~[")) + (set! conditional-nest (- conditional-nest 1)) + (if modifier + (format:error "no modifier allowed in ~~]")) + (if (not (null? params)) + (format:error "no parameter allowed in ~~]")) + (cond + ((zero? conditional-nest) + (let ((clause-str (substring format-string clause-pos + (- format:pos 2)))) + (if clause-default + (set! clause-default clause-str) + (set! clauses (append clauses (list clause-str))))) + (case conditional-type + ((if-then) + (if conditional-arg + (format:format-work (car clauses) + (list conditional-arg)))) + ((if-else-then) + (add-arg-pos + (format:format-work (if conditional-arg + (cadr clauses) + (car clauses)) + (rest-args)))) + ((num-case) + (if (or (not (integer? conditional-arg)) + (< conditional-arg 0)) + (format:error "argument not a positive integer")) + (if (not (and (>= conditional-arg (length clauses)) + (not clause-default))) + (add-arg-pos + (format:format-work + (if (>= conditional-arg (length clauses)) + clause-default + (list-ref clauses conditional-arg)) + (rest-args)))))))) + (anychar-dispatch)) + ((#\{) ; Iteration begin + (set! iteration-nest (+ iteration-nest 1)) + (cond + ((= iteration-nest 1) + (set! iteration-pos format:pos) + (set! iteration-type + (case modifier + ((at) 'rest-args) + ((colon) 'sublists) + ((colon-at) 'rest-sublists) + (else 'list))) + (set! max-iterations (if (one-positive-integer? params) + (car params) #f)))) + (anychar-dispatch)) + ((#\}) ; Iteration end + (if (zero? iteration-nest) (format:error "missing ~~{")) + (set! iteration-nest (- iteration-nest 1)) + (case modifier + ((colon) + (if (not max-iterations) (set! max-iterations 1))) + ((colon-at at) (format:error "illegal modifier")) + (else (if (not max-iterations) (set! max-iterations 100)))) + (if (not (null? params)) + (format:error "no parameters allowed in ~~}")) + (if (zero? iteration-nest) + (let ((iteration-str + (substring format-string iteration-pos + (- format:pos (if modifier 3 2))))) + (if (string=? iteration-str "") + (set! iteration-str (next-arg))) + (case iteration-type + ((list) + (let ((args (next-arg)) + (args-len 0)) + (if (not (list? args)) + (format:error "expected a list argument")) + (set! args-len (length args)) + (do ((arg-pos 0 (+ arg-pos + (format:format-work + iteration-str + (list-tail args arg-pos)))) + (i 0 (+ i 1))) + ((or (>= arg-pos args-len) + (>= i max-iterations)))))) + ((sublists) + (let ((args (next-arg)) + (args-len 0)) + (if (not (list? args)) + (format:error "expected a list argument")) + (set! args-len (length args)) + (do ((arg-pos 0 (+ arg-pos 1))) + ((or (>= arg-pos args-len) + (>= arg-pos max-iterations))) + (let ((sublist (list-ref args arg-pos))) + (if (not (list? sublist)) + (format:error + "expected a list of lists argument")) + (format:format-work iteration-str sublist))))) + ((rest-args) + (let* ((args (rest-args)) + (args-len (length args)) + (usedup-args + (do ((arg-pos 0 (+ arg-pos + (format:format-work + iteration-str + (list-tail + args arg-pos)))) + (i 0 (+ i 1))) + ((or (>= arg-pos args-len) + (>= i max-iterations)) + arg-pos)))) + (add-arg-pos usedup-args))) + ((rest-sublists) + (let* ((args (rest-args)) + (args-len (length args)) + (usedup-args + (do ((arg-pos 0 (+ arg-pos 1))) + ((or (>= arg-pos args-len) + (>= arg-pos max-iterations)) + arg-pos) + (let ((sublist (list-ref args arg-pos))) + (if (not (list? sublist)) + (format:error "expected list arguments")) + (format:format-work iteration-str sublist))))) + (add-arg-pos usedup-args))) + (else (format:error "internal error in ~~}"))))) + (anychar-dispatch)) + ((#\^) ; Up and out + (let* ((continue + (cond + ((not (null? params)) + (not + (case (length params) + ((1) (zero? (car params))) + ((2) (= (list-ref params 0) (list-ref params 1))) + ((3) (<= (list-ref params 0) + (list-ref params 1) + (list-ref params 2))) + (else (format:error "too much parameters"))))) + (format:case-conversion ; if conversion stop conversion + (set! format:case-conversion string-copy) #t) + ((= iteration-nest 1) #t) + ((= conditional-nest 1) #t) + ((>= arg-pos arg-len) + (set! format:pos format-string-len) #f) + (else #t)))) + (if continue + (anychar-dispatch)))) + + ;; format directive modifiers and parameters + + ((#\@) ; `@' modifier + (if (eq? modifier 'colon-at) + (format:error "double `@' modifier")) + (set! modifier (if (eq? modifier 'colon) 'colon-at 'at)) + (tilde-dispatch)) + ((#\:) ; `:' modifier + (if modifier (format:error "illegal `:' modifier position")) + (set! modifier 'colon) + (tilde-dispatch)) + ((#\') ; Character parameter + (if modifier (format:error "misplaced modifier")) + (set! params (append params (list (char->integer (next-char))))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr + (if modifier (format:error "misplaced modifier")) + (let ((num-str-beg (- format:pos 1)) + (num-str-end format:pos)) + (do ((ch (peek-next-char) (peek-next-char))) + ((not (char-numeric? ch))) + (next-char) + (set! num-str-end (+ 1 num-str-end))) + (set! params + (append params + (list (string->number + (substring format-string + num-str-beg + num-str-end)))))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\V) ; Variable parameter from next argum. + (if modifier (format:error "misplaced modifier")) + (set! params (append params (list (next-arg)))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\#) ; Parameter is number of remaining args + (if modifier (format:error "misplaced modifier")) + (set! params (append params (list (length (rest-args))))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\,) ; Parameter separators + (if modifier (format:error "misplaced modifier")) + (if (not param-value-found) + (set! params (append params '(#f)))) ; append empty paramtr + (set! param-value-found #f) + (tilde-dispatch)) + ((#\Q) ; Inquiry messages + (if (eq? modifier 'colon) + (format:out-str format:version) + (let ((nl (string #\newline))) + (format:out-str + (string-append + "SLIB Common LISP format version " format:version nl + " (C) copyright 1992-1994 by Dirk Lutzebaeck" nl + " please send bug reports to `lutzeb@cs.tu-berlin.de'" + nl)))) + (anychar-dispatch)) + (else ; Unknown tilde directive + (format:error "unknown control character `~c'" + (string-ref format-string (- format:pos 1)))))) + (else (anychar-dispatch)))))) ; in case of conditional + + (set! format:pos 0) + (set! format:arg-pos 0) + (anychar-dispatch) ; start the formatting + (set! format:pos recursive-pos-save) + arg-pos)) ; return the position in the arg. list + +;; format:obj->str returns a R4RS representation as a string of an arbitrary +;; scheme object. +;; First parameter is the object, second parameter is a boolean if the +;; representation should be slashified as `write' does. +;; It uses format:char->str which converts a character into +;; a slashified string as `write' does and which is implementation dependent. +;; It uses format:iobj->str to print out internal objects as +;; quoted strings so that the output can always be processed by (read) + +(define (format:obj->str obj slashify) + (cond + ((string? obj) + (if slashify + (let ((obj-len (string-length obj))) + (string-append + "\"" + (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm + (if (= j obj-len) + (string-append (substring obj i j) "\"") + (let ((c (string-ref obj j))) + (if (or (char=? c #\\) + (char=? c #\")) + (string-append (substring obj i j) "\\" + (loop j (+ j 1))) + (loop i (+ j 1)))))))) + obj)) + + ((boolean? obj) (if obj "#t" "#f")) + + ((number? obj) (number->string obj)) + + ((symbol? obj) + (if format:symbol-case-conv + (format:symbol-case-conv (symbol->string obj)) + (symbol->string obj))) + + ((char? obj) + (if slashify + (format:char->str obj) + (string obj))) + + ((null? obj) "()") + + ((input-port? obj) + (format:iobj->str obj)) + + ((output-port? obj) + (format:iobj->str obj)) + + ((list? obj) + (string-append "(" + (let loop ((obj-list obj)) + (if (null? (cdr obj-list)) + (format:obj->str (car obj-list) #t) + (string-append + (format:obj->str (car obj-list) #t) + " " + (loop (cdr obj-list))))) + ")")) + + ((pair? obj) + (string-append "(" + (format:obj->str (car obj) #t) + " . " + (format:obj->str (cdr obj) #t) + ")")) + + ((vector? obj) + (string-append "#" (format:obj->str (vector->list obj) #t))) + + (else ; only objects with an #<...> + (format:iobj->str obj)))) ; representation should fall in here + +;; format:iobj->str reveals the implementation dependent representation of +;; #<...> objects with the use of display and call-with-output-string. +;; If format:read-proof is set to #t the resulting string is additionally +;; set into string quotes. + +(define format:read-proof #f) + +(define (format:iobj->str iobj) + (if (or format:read-proof + format:iobj-case-conv) + (string-append + (if format:read-proof "\"" "") + (if format:iobj-case-conv + (format:iobj-case-conv + (call-with-output-string (lambda (p) (display iobj p)))) + (call-with-output-string (lambda (p) (display iobj p)))) + (if format:read-proof "\"" "")) + (call-with-output-string (lambda (p) (display iobj p))))) + + +;; format:char->str converts a character into a slashified string as +;; done by `write'. The procedure is dependent on the integer +;; representation of characters and assumes a character number according to +;; the ASCII character set. + +(define (format:char->str ch) + (let ((int-rep (char->integer ch))) + (if (< int-rep 0) ; if chars are [-128...+127] + (set! int-rep (+ int-rep 256))) + (string-append + "#\\" + (cond + ((char=? ch #\newline) "newline") + ((and (>= int-rep 0) (<= int-rep 32)) + (vector-ref format:ascii-non-printable-charnames int-rep)) + ((= int-rep 127) "del") + ((>= int-rep 128) ; octal representation + (if format:radix-pref + (let ((s (number->string int-rep 8))) + (substring s 2 (string-length s))) + (number->string int-rep 8))) + (else (string ch)))))) + +(define format:space-ch (char->integer #\space)) +(define format:zero-ch (char->integer #\0)) + +(define (format:par pars length index default name) + (if (> length index) + (let ((par (list-ref pars index))) + (if par + (if name + (if (< par 0) + (format:error + "~s parameter must be a positive integer" name) + par) + par) + default)) + default)) + +(define (format:out-obj-padded pad-left obj slashify pars) + (if (null? pars) + (format:out-str (format:obj->str obj slashify)) + (let ((l (length pars))) + (let ((mincol (format:par pars l 0 0 "mincol")) + (colinc (format:par pars l 1 1 "colinc")) + (minpad (format:par pars l 2 0 "minpad")) + (padchar (integer->char + (format:par pars l 3 format:space-ch #f))) + (objstr (format:obj->str obj slashify))) + (if (not pad-left) + (format:out-str objstr)) + (do ((objstr-len (string-length objstr)) + (i minpad (+ i colinc))) + ((>= (+ objstr-len i) mincol) + (format:out-fill i padchar))) + (if pad-left + (format:out-str objstr)))))) + +(define (format:out-num-padded modifier number pars radix) + (if (not (integer? number)) (format:error "argument not an integer")) + (let ((numstr (number->string number radix))) + (if (and format:radix-pref (not (= radix 10))) + (set! numstr (substring numstr 2 (string-length numstr)))) + (if (and (null? pars) (not modifier)) + (format:out-str numstr) + (let ((l (length pars)) + (numstr-len (string-length numstr))) + (let ((mincol (format:par pars l 0 #f "mincol")) + (padchar (integer->char + (format:par pars l 1 format:space-ch #f))) + (commachar (integer->char + (format:par pars l 2 (char->integer #\,) #f))) + (commawidth (format:par pars l 3 3 "commawidth"))) + (if mincol + (let ((numlen numstr-len)) ; calc. the output len of number + (if (and (memq modifier '(at colon-at)) (> number 0)) + (set! numlen (+ numlen 1))) + (if (memq modifier '(colon colon-at)) + (set! numlen (+ (quotient (- numstr-len + (if (< number 0) 2 1)) + commawidth) + numlen))) + (if (> mincol numlen) + (format:out-fill (- mincol numlen) padchar)))) + (if (and (memq modifier '(at colon-at)) + (> number 0)) + (format:out-char #\+)) + (if (memq modifier '(colon colon-at)) ; insert comma character + (let ((start (remainder numstr-len commawidth)) + (ns (if (< number 0) 1 0))) + (format:out-substr numstr 0 start) + (do ((i start (+ i commawidth))) + ((>= i numstr-len)) + (if (> i ns) + (format:out-char commachar)) + (format:out-substr numstr i (+ i commawidth)))) + (format:out-str numstr))))))) + +(define (format:tabulate modifier pars) + (let ((l (length pars))) + (let ((colnum (format:par pars l 0 1 "colnum")) + (colinc (format:par pars l 1 1 "colinc")) + (padch (integer->char (format:par pars l 2 format:space-ch #f)))) + (case modifier + ((colon colon-at) + (format:error "unsupported modifier for ~~t")) + ((at) ; relative tabulation + (format:out-fill + (if (= colinc 0) + colnum ; colnum = colrel + (do ((c 0 (+ c colinc)) + (col (+ format:output-col colnum))) + ((>= c col) + (- c format:output-col)))) + padch)) + (else ; absolute tabulation + (format:out-fill + (cond + ((< format:output-col colnum) + (- colnum format:output-col)) + ((= colinc 0) + 0) + (else + (do ((c colnum (+ c colinc))) + ((>= c format:output-col) + (- c format:output-col))))) + padch)))))) + + +;; roman numerals (from dorai@cs.rice.edu). + +(define format:roman-alist + '((1000 #\M) (500 #\D) (100 #\C) (50 #\L) + (10 #\X) (5 #\V) (1 #\I))) + +(define format:roman-boundary-values + '(100 100 10 10 1 1 #f)) + +(define format:num->old-roman + (lambda (n) + (if (and (integer? n) (>= n 1)) + (let loop ((n n) + (romans format:roman-alist) + (s '())) + (if (null? romans) (list->string (reverse s)) + (let ((roman-val (caar romans)) + (roman-dgt (cadar romans))) + (do ((q (quotient n roman-val) (- q 1)) + (s s (cons roman-dgt s))) + ((= q 0) + (loop (remainder n roman-val) + (cdr romans) s)))))) + (format:error "only positive integers can be romanized")))) + +(define format:num->roman + (lambda (n) + (if (and (integer? n) (> n 0)) + (let loop ((n n) + (romans format:roman-alist) + (boundaries format:roman-boundary-values) + (s '())) + (if (null? romans) + (list->string (reverse s)) + (let ((roman-val (caar romans)) + (roman-dgt (cadar romans)) + (bdry (car boundaries))) + (let loop2 ((q (quotient n roman-val)) + (r (remainder n roman-val)) + (s s)) + (if (= q 0) + (if (and bdry (>= r (- roman-val bdry))) + (loop (remainder r bdry) (cdr romans) + (cdr boundaries) + (cons roman-dgt + (append + (cdr (assv bdry romans)) + s))) + (loop r (cdr romans) (cdr boundaries) s)) + (loop2 (- q 1) r (cons roman-dgt s))))))) + (format:error "only positive integers can be romanized")))) + +;; cardinals & ordinals (from dorai@cs.rice.edu) + +(define format:cardinal-ones-list + '(#f "one" "two" "three" "four" "five" + "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen" + "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" + "nineteen")) + +(define format:cardinal-tens-list + '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" + "ninety")) + +(define format:num->cardinal999 + (lambda (n) + ;this procedure is inspired by the Bruno Haible's CLisp + ;function format-small-cardinal, which converts numbers + ;in the range 1 to 999, and is used for converting each + ;thousand-block in a larger number + (let* ((hundreds (quotient n 100)) + (tens+ones (remainder n 100)) + (tens (quotient tens+ones 10)) + (ones (remainder tens+ones 10))) + (append + (if (> hundreds 0) + (append + (string->list + (list-ref format:cardinal-ones-list hundreds)) + (string->list" hundred") + (if (> tens+ones 0) '(#\space) '())) + '()) + (if (< tens+ones 20) + (if (> tens+ones 0) + (string->list + (list-ref format:cardinal-ones-list tens+ones)) + '()) + (append + (string->list + (list-ref format:cardinal-tens-list tens)) + (if (> ones 0) + (cons #\- + (string->list + (list-ref format:cardinal-ones-list ones)))))))))) + +(define format:cardinal-thousand-block-list + '("" " thousand" " million" " billion" " trillion" " quadrillion" + " quintillion" " sextillion" " septillion" " octillion" " nonillion" + " decillion" " undecillion" " duodecillion" " tredecillion" + " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" + " octodecillion" " novemdecillion" " vigintillion")) + +(define format:num->cardinal + (lambda (n) + (cond ((not (integer? n)) + (format:error + "only integers can be converted to English cardinals")) + ((= n 0) "zero") + ((< n 0) (string-append "minus " (format:num->cardinal (- n)))) + (else + (let ((power3-word-limit + (length format:cardinal-thousand-block-list))) + (let loop ((n n) + (power3 0) + (s '())) + (if (= n 0) + (list->string s) + (let ((n-before-block (quotient n 1000)) + (n-after-block (remainder n 1000))) + (loop n-before-block + (+ power3 1) + (if (> n-after-block 0) + (append + (if (> n-before-block 0) + (string->list ", ") '()) + (format:num->cardinal999 n-after-block) + (if (< power3 power3-word-limit) + (string->list + (list-ref + format:cardinal-thousand-block-list + power3)) + (append + (string->list " times ten to the ") + (string->list + (format:num->ordinal + (* power3 3))) + (string->list " power"))) + s) + s)))))))))) + +(define format:ordinal-ones-list + '(#f "first" "second" "third" "fourth" "fifth" + "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth" + "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth" + "eighteenth" "nineteenth")) + +(define format:ordinal-tens-list + '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" + "seventieth" "eightieth" "ninetieth")) + +(define format:num->ordinal + (lambda (n) + (cond ((not (integer? n)) + (format:error + "only integers can be converted to English ordinals")) + ((= n 0) "zeroth") + ((< n 0) (string-append "minus " (format:num->ordinal (- n)))) + (else + (let ((hundreds (quotient n 100)) + (tens+ones (remainder n 100))) + (string-append + (if (> hundreds 0) + (string-append + (format:num->cardinal (* hundreds 100)) + (if (= tens+ones 0) "th" " ")) + "") + (if (= tens+ones 0) "" + (if (< tens+ones 20) + (list-ref format:ordinal-ones-list tens+ones) + (let ((tens (quotient tens+ones 10)) + (ones (remainder tens+ones 10))) + (if (= ones 0) + (list-ref format:ordinal-tens-list tens) + (string-append + (list-ref format:cardinal-tens-list tens) + "-" + (list-ref format:ordinal-ones-list ones)))) + )))))))) + +;; format fixed flonums (~F) + +(define (format:out-fixed modifier number pars) + (if (not (or (number? number) (string? number))) + (format:error "argument is not a number or a number string")) + + (let ((l (length pars))) + (let ((width (format:par pars l 0 #f "width")) + (digits (format:par pars l 1 #f "digits")) + (scale (format:par pars l 2 0 #f)) + (overch (format:par pars l 3 #f #f)) + (padch (format:par pars l 4 format:space-ch #f))) + + (if digits + + (begin ; fixed precision + (format:parse-float + (if (string? number) number (number->string number)) #t scale) + (if (<= (- format:fn-len format:fn-dot) digits) + (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) + (format:fn-round digits)) + (if width + (let ((numlen (+ format:fn-len 1))) + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (and (= format:fn-dot 0) (> width (+ digits 1))) + (set! numlen (+ numlen 1))) + (if (< numlen width) + (format:out-fill (- width numlen) (integer->char padch))) + (if (and overch (> numlen width)) + (format:out-fill width (integer->char overch)) + (format:fn-out modifier (> width (+ digits 1))))) + (format:fn-out modifier #t))) + + (begin ; free precision + (format:parse-float + (if (string? number) number (number->string number)) #t scale) + (format:fn-strip) + (if width + (let ((numlen (+ format:fn-len 1))) + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (= format:fn-dot 0) + (set! numlen (+ numlen 1))) + (if (< numlen width) + (format:out-fill (- width numlen) (integer->char padch))) + (if (> numlen width) ; adjust precision if possible + (let ((dot-index (- numlen + (- format:fn-len format:fn-dot)))) + (if (> dot-index width) + (if overch ; numstr too big for required width + (format:out-fill width (integer->char overch)) + (format:fn-out modifier #t)) + (begin + (format:fn-round (- width dot-index)) + (format:fn-out modifier #t)))) + (format:fn-out modifier #t))) + (format:fn-out modifier #t))))))) + +;; format exponential flonums (~E) + +(define (format:out-expon modifier number pars) + (if (not (or (number? number) (string? number))) + (format:error "argument is not a number")) + + (let ((l (length pars))) + (let ((width (format:par pars l 0 #f "width")) + (digits (format:par pars l 1 #f "digits")) + (edigits (format:par pars l 2 #f "exponent digits")) + (scale (format:par pars l 3 1 #f)) + (overch (format:par pars l 4 #f #f)) + (padch (format:par pars l 5 format:space-ch #f)) + (expch (format:par pars l 6 #f #f))) + + (if digits ; fixed precision + + (let ((digits (if (> scale 0) + (if (< scale (+ digits 2)) + (+ (- digits scale) 1) + 0) + digits))) + (format:parse-float + (if (string? number) number (number->string number)) #f scale) + (if (<= (- format:fn-len format:fn-dot) digits) + (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) + (format:fn-round digits)) + (if width + (if (and edigits overch (> format:en-len edigits)) + (format:out-fill width (integer->char overch)) + (let ((numlen (+ format:fn-len 3))) ; .E+ + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (and (= format:fn-dot 0) (> width (+ digits 1))) + (set! numlen (+ numlen 1))) + (set! numlen + (+ numlen + (if (and edigits (>= edigits format:en-len)) + edigits + format:en-len))) + (if (< numlen width) + (format:out-fill (- width numlen) + (integer->char padch))) + (if (and overch (> numlen width)) + (format:out-fill width (integer->char overch)) + (begin + (format:fn-out modifier (> width (- numlen 1))) + (format:en-out edigits expch))))) + (begin + (format:fn-out modifier #t) + (format:en-out edigits expch)))) + + (begin ; free precision + (format:parse-float + (if (string? number) number (number->string number)) #f scale) + (format:fn-strip) + (if width + (if (and edigits overch (> format:en-len edigits)) + (format:out-fill width (integer->char overch)) + (let ((numlen (+ format:fn-len 3))) ; .E+ + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (= format:fn-dot 0) + (set! numlen (+ numlen 1))) + (set! numlen + (+ numlen + (if (and edigits (>= edigits format:en-len)) + edigits + format:en-len))) + (if (< numlen width) + (format:out-fill (- width numlen) + (integer->char padch))) + (if (> numlen width) ; adjust precision if possible + (let ((f (- format:fn-len format:fn-dot))) ; fract len + (if (> (- numlen f) width) + (if overch ; numstr too big for required width + (format:out-fill width + (integer->char overch)) + (begin + (format:fn-out modifier #t) + (format:en-out edigits expch))) + (begin + (format:fn-round (+ (- f numlen) width)) + (format:fn-out modifier #t) + (format:en-out edigits expch)))) + (begin + (format:fn-out modifier #t) + (format:en-out edigits expch))))) + (begin + (format:fn-out modifier #t) + (format:en-out edigits expch)))))))) + +;; format general flonums (~G) + +(define (format:out-general modifier number pars) + (if (not (or (number? number) (string? number))) + (format:error "argument is not a number or a number string")) + + (let ((l (length pars))) + (let ((width (if (> l 0) (list-ref pars 0) #f)) + (digits (if (> l 1) (list-ref pars 1) #f)) + (edigits (if (> l 2) (list-ref pars 2) #f)) + (overch (if (> l 4) (list-ref pars 4) #f)) + (padch (if (> l 5) (list-ref pars 5) #f))) + (format:parse-float + (if (string? number) number (number->string number)) #t 0) + (format:fn-strip) + (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm + (ww (if width (- width ee) #f)) ; see Steele's CL book p.395 + (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ? + (- (format:fn-zlead)) + format:fn-dot)) + (d (if digits + digits + (max format:fn-len (min n 7)))) ; q = format:fn-len + (dd (- d n))) + (if (<= 0 dd d) + (begin + (format:out-fixed modifier number (list ww dd #f overch padch)) + (format:out-fill ee #\space)) ;~@T not implemented yet + (format:out-expon modifier number pars)))))) + +;; format dollar flonums (~$) + +(define (format:out-dollar modifier number pars) + (if (not (or (number? number) (string? number))) + (format:error "argument is not a number or a number string")) + + (let ((l (length pars))) + (let ((digits (format:par pars l 0 2 "digits")) + (mindig (format:par pars l 1 1 "mindig")) + (width (format:par pars l 2 0 "width")) + (padch (format:par pars l 3 format:space-ch #f))) + + (format:parse-float + (if (string? number) number (number->string number)) #t 0) + (if (<= (- format:fn-len format:fn-dot) digits) + (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) + (format:fn-round digits)) + (let ((numlen (+ format:fn-len 1))) + (if (or (not format:fn-pos?) (memq modifier '(at colon-at))) + (set! numlen (+ numlen 1))) + (if (and mindig (> mindig format:fn-dot)) + (set! numlen (+ numlen (- mindig format:fn-dot)))) + (if (and (= format:fn-dot 0) (not mindig)) + (set! numlen (+ numlen 1))) + (if (< numlen width) + (case modifier + ((colon) + (if (not format:fn-pos?) + (format:out-char #\-)) + (format:out-fill (- width numlen) (integer->char padch))) + ((at) + (format:out-fill (- width numlen) (integer->char padch)) + (format:out-char (if format:fn-pos? #\+ #\-))) + ((colon-at) + (format:out-char (if format:fn-pos? #\+ #\-)) + (format:out-fill (- width numlen) (integer->char padch))) + (else + (format:out-fill (- width numlen) (integer->char padch)) + (if (not format:fn-pos?) + (format:out-char #\-)))) + (if format:fn-pos? + (if (memq modifier '(at colon-at)) (format:out-char #\+)) + (format:out-char #\-)))) + (if (and mindig (> mindig format:fn-dot)) + (format:out-fill (- mindig format:fn-dot) #\0)) + (if (and (= format:fn-dot 0) (not mindig)) + (format:out-char #\0)) + (format:out-substr format:fn-str 0 format:fn-dot) + (format:out-char #\.) + (format:out-substr format:fn-str format:fn-dot format:fn-len)))) + +; the flonum buffers + +(define format:fn-max 200) ; max. number of number digits +(define format:fn-str (make-string format:fn-max)) ; number buffer +(define format:fn-len 0) ; digit length of number +(define format:fn-dot #f) ; dot position of number +(define format:fn-pos? #t) ; number positive? +(define format:en-max 10) ; max. number of exponent digits +(define format:en-str (make-string format:en-max)) ; exponent buffer +(define format:en-len 0) ; digit length of exponent +(define format:en-pos? #t) ; exponent positive? + +(define (format:parse-float num-str fixed? scale) + (set! format:fn-pos? #t) + (set! format:fn-len 0) + (set! format:fn-dot #f) + (set! format:en-pos? #t) + (set! format:en-len 0) + (do ((i 0 (+ i 1)) + (left-zeros 0) + (mantissa? #t) + (all-zeros? #t) + (num-len (string-length num-str)) + (c #f)) ; current exam. character in num-str + ((= i num-len) + (if (not format:fn-dot) + (set! format:fn-dot format:fn-len)) + + (if all-zeros? + (begin + (set! left-zeros 0) + (set! format:fn-dot 0) + (set! format:fn-len 1))) + + ;; now format the parsed values according to format's need + + (if fixed? + + (begin ; fixed format m.nnn or .nnn + (if (and (> left-zeros 0) (> format:fn-dot 0)) + (if (> format:fn-dot left-zeros) + (begin ; norm 0{0}nn.mm to nn.mm + (format:fn-shiftleft left-zeros) + (set! left-zeros 0) + (set! format:fn-dot (- format:fn-dot left-zeros))) + (begin ; normalize 0{0}.nnn to .nnn + (format:fn-shiftleft format:fn-dot) + (set! left-zeros (- left-zeros format:fn-dot)) + (set! format:fn-dot 0)))) + (if (or (not (= scale 0)) (> format:en-len 0)) + (let ((shift (+ scale (format:en-int)))) + (cond + (all-zeros? #t) + ((> (+ format:fn-dot shift) format:fn-len) + (format:fn-zfill + #f (- shift (- format:fn-len format:fn-dot))) + (set! format:fn-dot format:fn-len)) + ((< (+ format:fn-dot shift) 0) + (format:fn-zfill #t (- (- shift) format:fn-dot)) + (set! format:fn-dot 0)) + (else + (if (> left-zeros 0) + (if (<= left-zeros shift) ; shift always > 0 here + (format:fn-shiftleft shift) ; shift out 0s + (begin + (format:fn-shiftleft left-zeros) + (set! format:fn-dot (- shift left-zeros)))) + (set! format:fn-dot (+ format:fn-dot shift)))))))) + + (let ((negexp ; expon format m.nnnEee + (if (> left-zeros 0) + (- left-zeros format:fn-dot -1) + (if (= format:fn-dot 0) 1 0)))) + (if (> left-zeros 0) + (begin ; normalize 0{0}.nnn to n.nn + (format:fn-shiftleft left-zeros) + (set! format:fn-dot 1)) + (if (= format:fn-dot 0) + (set! format:fn-dot 1))) + (format:en-set (- (+ (- format:fn-dot scale) (format:en-int)) + negexp)) + (cond + (all-zeros? + (format:en-set 0) + (set! format:fn-dot 1)) + ((< scale 0) ; leading zero + (format:fn-zfill #t (- scale)) + (set! format:fn-dot 0)) + ((> scale format:fn-dot) + (format:fn-zfill #f (- scale format:fn-dot)) + (set! format:fn-dot scale)) + (else + (set! format:fn-dot scale))))) + #t) + + ;; do body + (set! c (string-ref num-str i)) ; parse the output of number->string + (cond ; which can be any valid number + ((char-numeric? c) ; representation of R4RS except + (if mantissa? ; complex numbers + (begin + (if (char=? c #\0) + (if all-zeros? + (set! left-zeros (+ left-zeros 1))) + (begin + (set! all-zeros? #f))) + (string-set! format:fn-str format:fn-len c) + (set! format:fn-len (+ format:fn-len 1))) + (begin + (string-set! format:en-str format:en-len c) + (set! format:en-len (+ format:en-len 1))))) + ((or (char=? c #\-) (char=? c #\+)) + (if mantissa? + (set! format:fn-pos? (char=? c #\+)) + (set! format:en-pos? (char=? c #\+)))) + ((char=? c #\.) + (set! format:fn-dot format:fn-len)) + ((char=? c #\e) + (set! mantissa? #f)) + ((char=? c #\E) + (set! mantissa? #f)) + ((char-whitespace? c) #t) + ((char=? c #\d) #t) ; decimal radix prefix + ((char=? c #\#) #t) + (else + (format:error "illegal character `~c' in number->string" c))))) + +(define (format:en-int) ; convert exponent string to integer + (if (= format:en-len 0) + 0 + (do ((i 0 (+ i 1)) + (n 0)) + ((= i format:en-len) + (if format:en-pos? + n + (- n))) + (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i)) + format:zero-ch)))))) + +(define (format:en-set en) ; set exponent string number + (set! format:en-len 0) + (set! format:en-pos? (>= en 0)) + (let ((en-str (number->string en))) + (do ((i 0 (+ i 1)) + (en-len (string-length en-str)) + (c #f)) + ((= i en-len)) + (set! c (string-ref en-str i)) + (if (char-numeric? c) + (begin + (string-set! format:en-str format:en-len c) + (set! format:en-len (+ format:en-len 1))))))) + +(define (format:fn-zfill left? n) ; fill current number string with 0s + (if (> (+ n format:fn-len) format:fn-max) ; from the left or right + (format:error "number is too long to format (enlarge format:fn-max)")) + (set! format:fn-len (+ format:fn-len n)) + (if left? + (do ((i format:fn-len (- i 1))) ; fill n 0s to left + ((< i 0)) + (string-set! format:fn-str i + (if (< i n) + #\0 + (string-ref format:fn-str (- i n))))) + (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right + ((= i format:fn-len)) + (string-set! format:fn-str i #\0)))) + +(define (format:fn-shiftleft n) ; shift left current number n positions + (if (> n format:fn-len) + (format:error "internal error in format:fn-shiftleft (~d,~d)" + n format:fn-len)) + (do ((i n (+ i 1))) + ((= i format:fn-len) + (set! format:fn-len (- format:fn-len n))) + (string-set! format:fn-str (- i n) (string-ref format:fn-str i)))) + +(define (format:fn-round digits) ; round format:fn-str + (set! digits (+ digits format:fn-dot)) + (do ((i digits (- i 1)) ; "099",2 -> "10" + (c 5)) ; "023",2 -> "02" + ((or (= c 0) (< i 0)) ; "999",2 -> "100" + (if (= c 1) ; "005",2 -> "01" + (begin ; carry overflow + (set! format:fn-len digits) + (format:fn-zfill #t 1) ; add a 1 before fn-str + (string-set! format:fn-str 0 #\1) + (set! format:fn-dot (+ format:fn-dot 1))) + (set! format:fn-len digits))) + (set! c (+ (- (char->integer (string-ref format:fn-str i)) + format:zero-ch) c)) + (string-set! format:fn-str i (integer->char + (if (< c 10) + (+ c format:zero-ch) + (+ (- c 10) format:zero-ch)))) + (set! c (if (< c 10) 0 1)))) + +(define (format:fn-out modifier add-leading-zero?) + (if format:fn-pos? + (if (eq? modifier 'at) + (format:out-char #\+)) + (format:out-char #\-)) + (if (= format:fn-dot 0) + (if add-leading-zero? + (format:out-char #\0)) + (format:out-substr format:fn-str 0 format:fn-dot)) + (format:out-char #\.) + (format:out-substr format:fn-str format:fn-dot format:fn-len)) + +(define (format:en-out edigits expch) + (format:out-char (if expch (integer->char expch) format:expch)) + (format:out-char (if format:en-pos? #\+ #\-)) + (if edigits + (if (< format:en-len edigits) + (format:out-fill (- edigits format:en-len) #\0))) + (format:out-substr format:en-str 0 format:en-len)) + +(define (format:fn-strip) ; strip trailing zeros but one + (string-set! format:fn-str format:fn-len #\0) + (do ((i format:fn-len (- i 1))) + ((or (not (char=? (string-ref format:fn-str i) #\0)) + (<= i format:fn-dot)) + (set! format:fn-len (+ i 1))))) + +(define (format:fn-zlead) ; count leading zeros + (do ((i 0 (+ i 1))) + ((or (= i format:fn-len) + (not (char=? (string-ref format:fn-str i) #\0))) + (if (= i format:fn-len) ; found a real zero + 0 + i)))) + + +;;; some global functions not found in SLIB + +;; string-index finds the index of the first occurence of the character `c' +;; in the string `s'; it returns #f if there is no such character in `s'. + +(define (string-index s c) + (let ((slen-1 (- (string-length s) 1))) + (let loop ((i 0)) + (cond + ((char=? c (string-ref s i)) i) + ((= i slen-1) #f) + (else (loop (+ i 1))))))) + +(define (string-capitalize-first str) ; "hello" -> "Hello" + (let ((cap-str (string-copy str)) ; "hELLO" -> "Hello" + (non-first-alpha #f) ; "*hello" -> "*Hello" + (str-len (string-length str))) ; "hello you" -> "Hello you" + (do ((i 0 (+ i 1))) + ((= i str-len) cap-str) + (let ((c (string-ref str i))) + (if (char-alphabetic? c) + (if non-first-alpha + (string-set! cap-str i (char-downcase c)) + (begin + (set! non-first-alpha #t) + (string-set! cap-str i (char-upcase c))))))))) + +(define (list-head l k) + (if (= k 0) + '() + (cons (car l) (list-head (cdr l) (- k 1))))) + + +;; Aborts the program when a formatting error occures. This is a null +;; argument closure to jump to the interpreters toplevel continuation. + +(define format:abort (lambda () (slib:error "error in format"))) + +(define format format:format) + +;; If this is not possible then a continuation is used to recover +;; properly from a format error. In this case format returns #f. + +;(define format:abort +; (lambda () (format:error-continuation #f))) + +;(define format +; (lambda args ; wraps format:format with an error +; (call-with-current-continuation ; continuation +; (lambda (cont) +; (set! format:error-continuation cont) +; (apply format:format args))))) + +;eof diff --git a/formatst.scm b/formatst.scm new file mode 100644 index 0000000..7a2173e --- /dev/null +++ b/formatst.scm @@ -0,0 +1,647 @@ +;; "formatst.scm" SLIB FORMAT Version 3.0 conformance test +; Written by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de) +; +; This code is in the public domain. + +;; Test run: (slib:load "formatst") + +; Failure reports for various scheme interpreters: +; +; SCM4d +; None. +; Elk 2.2: +; None. +; MIT C-Scheme 7.1: +; The empty list is always evaluated as a boolean and consequently +; represented as `#f'. +; Scheme->C 01nov91: +; None, if format:symbol-case-conv and format:iobj-case-conv are set +; to string-downcase. + +(require 'format) +(if (not (string=? format:version "3.0")) + (begin + (display "You have format version ") + (display format:version) + (display ". This test is for format version 3.0!") + (newline) + (format:abort))) + +(define fails 0) +(define total 0) +(define test-verbose #f) ; shows each test performed + +(define (test format-args out-str) + (set! total (+ total 1)) + (if (not test-verbose) + (if (zero? (modulo total 10)) + (begin + (display total) + (display ",") + (force-output (current-output-port))))) + (let ((format-out (apply format `(#f ,@format-args)))) + (if (string=? out-str format-out) + (if test-verbose + (begin + (display "Verified ") + (write format-args) + (display " returns ") + (write out-str) + (newline))) + (begin + (set! fails (+ fails 1)) + (if (not test-verbose) (newline)) + (display "*Failed* ") + (write format-args) + (newline) + (display " returns ") + (write format-out) + (newline) + (display " expected ") + (write out-str) + (newline))))) + +; ensure format default configuration + +(set! format:symbol-case-conv #f) +(set! format:iobj-case-conv #f) +(set! format:read-proof #f) + +(format #t "~q") + +(format #t "This implementation has~@[ no~] flonums ~ + ~:[but no~;and~] complex numbers~%" + (not format:floats) format:complex-numbers) + +; any object test + +(test '("abc") "abc") +(test '("~a" 10) "10") +(test '("~a" -1.2) "-1.2") +(test '("~a" a) "a") +(test '("~a" #t) "#t") +(test '("~a" #f) "#f") +(test '("~a" "abc") "abc") +(test '("~a" #(1 2 3)) "#(1 2 3)") +(test '("~a" ()) "()") +(test '("~a" (a)) "(a)") +(test '("~a" (a b)) "(a b)") +(test '("~a" (a (b c) d)) "(a (b c) d)") +(test '("~a" (a . b)) "(a . b)") +(test '("~a" (a (b c . d))) "(a (b . (c . d)))") ; this is ugly +(test `("~a" ,display) (format:iobj->str display)) +(test `("~a" ,(current-input-port)) (format:iobj->str (current-input-port))) +(test `("~a" ,(current-output-port)) (format:iobj->str (current-output-port))) + +; # argument test + +(test '("~a ~a" 10 20) "10 20") +(test '("~a abc ~a def" 10 20) "10 abc 20 def") + +; numerical test + +(test '("~d" 100) "100") +(test '("~x" 100) "64") +(test '("~o" 100) "144") +(test '("~b" 100) "1100100") +(test '("~@d" 100) "+100") +(test '("~@d" -100) "-100") +(test '("~@x" 100) "+64") +(test '("~@o" 100) "+144") +(test '("~@b" 100) "+1100100") +(test '("~10d" 100) " 100") +(test '("~:d" 123) "123") +(test '("~:d" 1234) "1,234") +(test '("~:d" 12345) "12,345") +(test '("~:d" 123456) "123,456") +(test '("~:d" 12345678) "12,345,678") +(test '("~:d" -123) "-123") +(test '("~:d" -1234) "-1,234") +(test '("~:d" -12345) "-12,345") +(test '("~:d" -123456) "-123,456") +(test '("~:d" -12345678) "-12,345,678") +(test '("~10:d" 1234) " 1,234") +(test '("~10:d" -1234) " -1,234") +(test '("~10,'*d" 100) "*******100") +(test '("~10,,'|:d" 12345678) "12|345|678") +(test '("~10,,,2:d" 12345678) "12,34,56,78") +(test '("~14,'*,'|,4:@d" 12345678) "****+1234|5678") +(test '("~10r" 100) "100") +(test '("~2r" 100) "1100100") +(test '("~8r" 100) "144") +(test '("~16r" 100) "64") +(test '("~16,10,'*r" 100) "********64") + +; roman numeral test + +(test '("~@r" 4) "IV") +(test '("~@r" 19) "XIX") +(test '("~@r" 50) "L") +(test '("~@r" 100) "C") +(test '("~@r" 1000) "M") +(test '("~@r" 99) "XCIX") +(test '("~@r" 1994) "MCMXCIV") + +; old roman numeral test + +(test '("~:@r" 4) "IIII") +(test '("~:@r" 5) "V") +(test '("~:@r" 10) "X") +(test '("~:@r" 9) "VIIII") + +; cardinal/ordinal English number test + +(test '("~r" 4) "four") +(test '("~r" 10) "ten") +(test '("~r" 19) "nineteen") +(test '("~r" 1984) "one thousand, nine hundred eighty-four") +(test '("~:r" -1984) "minus one thousand, nine hundred eighty-fourth") + +; character test + +(test '("~c" #\a) "a") +(test '("~@c" #\a) "#\\a") +(test `("~@c" ,(integer->char 32)) "#\\space") +(test `("~@c" ,(integer->char 0)) "#\\nul") +(test `("~@c" ,(integer->char 27)) "#\\esc") +(test `("~@c" ,(integer->char 127)) "#\\del") +(test `("~@c" ,(integer->char 128)) "#\\200") +(test `("~@c" ,(integer->char 255)) "#\\377") +(test '("~65c") "A") +(test '("~7@c") "#\\bel") +(test '("~:c" #\a) "a") +(test `("~:c" ,(integer->char 1)) "^A") +(test `("~:c" ,(integer->char 27)) "^[") +(test '("~7:c") "^G") +(test `("~:c" ,(integer->char 128)) "#\\200") +(test `("~:c" ,(integer->char 127)) "#\\177") +(test `("~:c" ,(integer->char 255)) "#\\377") + + +; plural test + +(test '("test~p" 1) "test") +(test '("test~p" 2) "tests") +(test '("test~p" 0) "tests") +(test '("tr~@p" 1) "try") +(test '("tr~@p" 2) "tries") +(test '("tr~@p" 0) "tries") +(test '("~a test~:p" 10) "10 tests") +(test '("~a test~:p" 1) "1 test") + +; tilde test + +(test '("~~~~") "~~") +(test '("~3~") "~~~") + +; whitespace character test + +(test '("~%") " +") +(test '("~3%") " + + +") +(test '("~&") "") +(test '("abc~&") "abc +") +(test '("abc~&def") "abc +def") +(test '("~&") " +") +(test '("~3&") " + +") +(test '("abc~3&") "abc + + +") +(test '("~|") (string slib:form-feed)) +(test '("~_~_~_") " ") +(test '("~3_") " ") +(test '("~/") (string slib:tab)) +(test '("~3/") (make-string 3 slib:tab)) + +; tabulate test + +(test '("~0&~3t") " ") +(test '("~0&~10t") " ") +(test '("~10t") "") +(test '("~0&1234567890~,8tABC") "1234567890 ABC") +(test '("~0&1234567890~0,8tABC") "1234567890 ABC") +(test '("~0&1234567890~1,8tABC") "1234567890 ABC") +(test '("~0&1234567890~2,8tABC") "1234567890ABC") +(test '("~0&1234567890~3,8tABC") "1234567890 ABC") +(test '("~0&1234567890~4,8tABC") "1234567890 ABC") +(test '("~0&1234567890~5,8tABC") "1234567890 ABC") +(test '("~0&1234567890~6,8tABC") "1234567890 ABC") +(test '("~0&1234567890~7,8tABC") "1234567890 ABC") +(test '("~0&1234567890~8,8tABC") "1234567890 ABC") +(test '("~0&1234567890~9,8tABC") "1234567890 ABC") +(test '("~0&1234567890~10,8tABC") "1234567890ABC") +(test '("~0&1234567890~11,8tABC") "1234567890 ABC") +(test '("~0&12345~,8tABCDE~,8tXYZ") "12345 ABCDE XYZ") +(test '("~,8t+++~,8t===") " +++ ===") +(test '("~0&ABC~,8,'.tDEF") "ABC......DEF") +(test '("~0&~3,8@tABC") " ABC") +(test '("~0&1234~3,8@tABC") "1234 ABC") +(test '("~0&12~3,8@tABC~3,8@tDEF") "12 ABC DEF") + +; indirection test + +(test '("~a ~? ~a" 10 "~a ~a" (20 30) 40) "10 20 30 40") +(test '("~a ~@? ~a" 10 "~a ~a" 20 30 40) "10 20 30 40") + +; field test + +(test '("~10a" "abc") "abc ") +(test '("~10@a" "abc") " abc") +(test '("~10a" "0123456789abc") "0123456789abc") +(test '("~10@a" "0123456789abc") "0123456789abc") + +; pad character test + +(test '("~10,,,'*a" "abc") "abc*******") +(test '("~10,,,'Xa" "abc") "abcXXXXXXX") +(test '("~10,,,42a" "abc") "abc*******") +(test '("~10,,,'*@a" "abc") "*******abc") +(test '("~10,,3,'*a" "abc") "abc*******") +(test '("~10,,3,'*a" "0123456789abc") "0123456789abc***") ; min. padchar length +(test '("~10,,3,'*@a" "0123456789abc") "***0123456789abc") + +; colinc, minpad padding test + +(test '("~10,8,0,'*a" 123) "123********") +(test '("~10,9,0,'*a" 123) "123*********") +(test '("~10,10,0,'*a" 123) "123**********") +(test '("~10,11,0,'*a" 123) "123***********") +(test '("~8,1,0,'*a" 123) "123*****") +(test '("~8,2,0,'*a" 123) "123******") +(test '("~8,3,0,'*a" 123) "123******") +(test '("~8,4,0,'*a" 123) "123********") +(test '("~8,5,0,'*a" 123) "123*****") +(test '("~8,1,3,'*a" 123) "123*****") +(test '("~8,1,5,'*a" 123) "123*****") +(test '("~8,1,6,'*a" 123) "123******") +(test '("~8,1,9,'*a" 123) "123*********") + +; slashify test + +(test '("~s" "abc") "\"abc\"") +(test '("~s" "abc \\ abc") "\"abc \\\\ abc\"") +(test '("~a" "abc \\ abc") "abc \\ abc") +(test '("~s" "abc \" abc") "\"abc \\\" abc\"") +(test '("~a" "abc \" abc") "abc \" abc") +(test '("~s" #\space) "#\\space") +(test '("~s" #\newline) "#\\newline") +(test '("~s" #\tab) "#\\ht") +(test '("~s" #\a) "#\\a") +(test '("~a" (a "b" c)) "(a \"b\" c)") + +; symbol case force test + +(define format:old-scc format:symbol-case-conv) +(set! format:symbol-case-conv string-upcase) +(test '("~a" abc) "ABC") +(set! format:symbol-case-conv string-downcase) +(test '("~s" abc) "abc") +(set! format:symbol-case-conv string-capitalize) +(test '("~s" abc) "Abc") +(set! format:symbol-case-conv format:old-scc) + +; read proof test + +(test `("~:s" ,display) + (begin + (set! format:read-proof #t) + (format:iobj->str display))) +(test `("~:a" ,display) + (begin + (set! format:read-proof #t) + (format:iobj->str display))) +(test `("~:a" (1 2 ,display)) + (begin + (set! format:read-proof #t) + (string-append "(1 2 " (format:iobj->str display) ")"))) +(test '("~:a" "abc") "abc") +(set! format:read-proof #f) + +; internal object case type force test + +(set! format:iobj-case-conv string-upcase) +(test `("~a" ,display) (string-upcase (format:iobj->str display))) +(set! format:iobj-case-conv string-downcase) +(test `("~s" ,display) (string-downcase (format:iobj->str display))) +(set! format:iobj-case-conv string-capitalize) +(test `("~s" ,display) (string-capitalize (format:iobj->str display))) +(set! format:iobj-case-conv #f) + +; continuation line test + +(test '("abc~ + 123") "abc123") +(test '("abc~ +123") "abc123") +(test '("abc~ +") "abc") +(test '("abc~: + def") "abc def") +(test '("abc~@ + def") +"abc +def") + +; flush output (can't test it here really) + +(test '("abc ~! xyz") "abc xyz") + +; string case conversion + +(test '("~a ~(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc hello world xyz") +(test '("~a ~:(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello World xyz") +(test '("~a ~@(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello world xyz") +(test '("~a ~:@(~a~) ~a" "abc" "hello world" "xyz") "abc HELLO WORLD xyz") +(test '("~:@(~a~)" (a b c)) "(A B C)") +(test '("~:@(~x~)" 255) "FF") +(test '("~:@(~p~)" 2) "S") +(test `("~:@(~a~)" ,display) (string-upcase (format:iobj->str display))) +(test '("~:(~a ~a ~a~) ~a" "abc" "xyz" "123" "world") "Abc Xyz 123 world") + +; variable parameter + +(test '("~va" 10 "abc") "abc ") +(test '("~v,,,va" 10 42 "abc") "abc*******") + +; number of remaining arguments as parameter + +(test '("~#,,,'*@a ~a ~a ~a" 1 1 1 1) "***1 1 1 1") + +; argument jumping + +(test '("~a ~* ~a" 10 20 30) "10 30") +(test '("~a ~2* ~a" 10 20 30 40) "10 40") +(test '("~a ~:* ~a" 10) "10 10") +(test '("~a ~a ~2:* ~a ~a" 10 20) "10 20 10 20") +(test '("~a ~a ~@* ~a ~a" 10 20) "10 20 10 20") +(test '("~a ~a ~4@* ~a ~a" 10 20 30 40 50 60) "10 20 50 60") + +; conditionals + +(test '("~[abc~;xyz~]" 0) "abc") +(test '("~[abc~;xyz~]" 1) "xyz") +(test '("~[abc~;xyz~:;456~]" 99) "456") +(test '("~0[abc~;xyz~:;456~]") "abc") +(test '("~1[abc~;xyz~:;456~] ~a" 100) "xyz 100") +(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]") "no arg") +(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10) "10") +(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20) "10 and 20") +(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20 30) "10, 20 and 30") +(test '("~:[hello~;world~] ~a" #t 10) "world 10") +(test '("~:[hello~;world~] ~a" #f 10) "hello 10") +(test '("~@[~a tests~]" #f) "") +(test '("~@[~a tests~]" 10) "10 tests") +(test '("~@[~a test~:p~] ~a" 10 done) "10 tests done") +(test '("~@[~a test~:p~] ~a" 1 done) "1 test done") +(test '("~@[~a test~:p~] ~a" 0 done) "0 tests done") +(test '("~@[~a test~:p~] ~a" #f done) " done") +(test '("~@[ level = ~d~]~@[ length = ~d~]" #f 5) " length = 5") +(test '("~[abc~;~[4~;5~;6~]~;xyz~]" 0) "abc") ; nested conditionals (irrghh) +(test '("~[abc~;~[4~;5~;6~]~;xyz~]" 2) "xyz") +(test '("~[abc~;~[4~;5~;6~]~;xyz~]" 1 2) "6") + +; iteration + +(test '("~{ ~a ~}" (a b c)) " a b c ") +(test '("~{ ~a ~}" ()) "") +(test '("~{ ~a ~5,,,'*a~}" (a b c d)) " a b**** c d****") +(test '("~{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1 b,2 c,3 ") +(test '("~2{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1 b,2 ") +(test '("~3{~a ~} ~a" (a b c d e) 100) "a b c 100") +(test '("~0{~a ~} ~a" (a b c d e) 100) " 100") +(test '("~:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b c,d g,h ") +(test '("~2:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b c,d ") +(test '("~@{ ~a,~a ~}" a 1 b 2 c 3) " a,1 b,2 c,3 ") +(test '("~2@{ ~a,~a ~} <~a|~a>" a 1 b 2 c 3) " a,1 b,2 ") +(test '("~:@{ ~a,~a ~}" (a 1) (b 2) (c 3)) " a,1 b,2 c,3 ") +(test '("~2:@{ ~a,~a ~} ~a" (a 1) (b 2) (c 3)) " a,1 b,2 (c 3)") +(test '("~{~}" "<~a,~a>" (a 1 b 2 c 3)) "") +(test '("~{ ~a ~{<~a>~}~} ~a" (a (1 2) b (3 4)) 10) " a <1><2> b <3><4> 10") + +; up and out + +(test '("abc ~^ xyz") "abc ") +(test '("~@(abc ~^ xyz~) ~a" 10) "ABC xyz 10") +(test '("done. ~^ ~d warning~:p. ~^ ~d error~:p.") "done. ") +(test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10) "done. 10 warnings. ") +(test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10 1) + "done. 10 warnings. 1 error.") +(test '("~{ ~a ~^<~a>~} ~a" (a b c d e f) 10) " a c e 10") +(test '("~{ ~a ~^<~a>~} ~a" (a b c d e) 10) " a c e 10") +(test '("abc~0^ xyz") "abc") +(test '("abc~9^ xyz") "abc xyz") +(test '("abc~7,4^ xyz") "abc xyz") +(test '("abc~7,7^ xyz") "abc") +(test '("abc~3,7,9^ xyz") "abc") +(test '("abc~8,7,9^ xyz") "abc xyz") +(test '("abc~3,7,5^ xyz") "abc xyz") + +; complexity tests (oh my god, I hardly understand them myself (see CL std)) + +(define fmt "Items:~#[ none~; ~a~; ~a and ~a~:;~@{~#[~; and~] ~a~^,~}~].") + +(test `(,fmt ) "Items: none.") +(test `(,fmt foo) "Items: foo.") +(test `(,fmt foo bar) "Items: foo and bar.") +(test `(,fmt foo bar baz) "Items: foo, bar, and baz.") +(test `(,fmt foo bar baz zok) "Items: foo, bar, baz, and zok.") + +; fixed floating points + +(cond + (format:floats + (test '("~6,2f" 3.14159) " 3.14") + (test '("~6,1f" 3.14159) " 3.1") + (test '("~6,0f" 3.14159) " 3.") + (test '("~5,1f" 0) " 0.0") + (test '("~10,7f" 3.14159) " 3.1415900") + (test '("~10,7f" -3.14159) "-3.1415900") + (test '("~10,7@f" 3.14159) "+3.1415900") + (test '("~6,3f" 0.0) " 0.000") + (test '("~6,4f" 0.007) "0.0070") + (test '("~6,3f" 0.007) " 0.007") + (test '("~6,2f" 0.007) " 0.01") + (test '("~3,2f" 0.007) ".01") + (test '("~3,2f" -0.007) "-.01") + (test '("~6,2,,,'*f" 3.14159) "**3.14") + (test '("~6,3,,'?f" 12345.56789) "??????") + (test '("~6,3f" 12345.6789) "12345.679") + (test '("~,3f" 12345.6789) "12345.679") + (test '("~,3f" 9.9999) "10.000") + (test '("~6f" 23.4) " 23.4") + (test '("~6f" 1234.5) "1234.5") + (test '("~6f" 12345678) "12345678.0") + (test '("~6,,,'?f" 12345678) "??????") + (test '("~6f" 123.56789) "123.57") + (test '("~6f" 123.0) " 123.0") + (test '("~6f" -123.0) "-123.0") + (test '("~6f" 0.0) " 0.0") + (test '("~3f" 3.141) "3.1") + (test '("~2f" 3.141) "3.") + (test '("~1f" 3.141) "3.141") + (test '("~f" 123.56789) "123.56789") + (test '("~f" -314.0) "-314.0") + (test '("~f" 1e4) "10000.0") + (test '("~f" -1.23e10) "-12300000000.0") + (test '("~f" 1e-4) "0.0001") + (test '("~f" -1.23e-10) "-0.000000000123") + (test '("~@f" 314.0) "+314.0") + (test '("~,,3f" 0.123456) "123.456") + (test '("~,,-3f" -123.456) "-0.123456") + (test '("~5,,3f" 0.123456) "123.5") +)) + +; exponent floating points + +(cond + (format:floats + (test '("~e" 3.14159) "3.14159E+0") + (test '("~e" 0.00001234) "1.234E-5") + (test '("~,,,0e" 0.00001234) "0.1234E-4") + (test '("~,3e" 3.14159) "3.142E+0") + (test '("~,3@e" 3.14159) "+3.142E+0") + (test '("~,3@e" 0.0) "+0.000E+0") + (test '("~,0e" 3.141) "3.E+0") + (test '("~,3,,0e" 3.14159) "0.314E+1") + (test '("~,5,3,-2e" 3.14159) "0.00314E+003") + (test '("~,5,3,-5e" -3.14159) "-0.00000E+006") + (test '("~,5,2,2e" 3.14159) "31.4159E-01") + (test '("~,5,2,,,,'ee" 0.0) "0.00000e+00") + (test '("~12,3e" -3.141) " -3.141E+0") + (test '("~12,3,,,,'#e" -3.141) "###-3.141E+0") + (test '("~10,2e" -1.236e-4) " -1.24E-4") + (test '("~5,3e" -3.141) "-3.141E+0") + (test '("~5,3,,,'*e" -3.141) "*****") + (test '("~3e" 3.14159) "3.14159E+0") + (test '("~4e" 3.14159) "3.14159E+0") + (test '("~5e" 3.14159) "3.E+0") + (test '("~5,,,,'*e" 3.14159) "3.E+0") + (test '("~6e" 3.14159) "3.1E+0") + (test '("~7e" 3.14159) "3.14E+0") + (test '("~7e" -3.14159) "-3.1E+0") + (test '("~8e" 3.14159) "3.142E+0") + (test '("~9e" 3.14159) "3.1416E+0") + (test '("~9,,,,,,'ee" 3.14159) "3.1416e+0") + (test '("~10e" 3.14159) "3.14159E+0") + (test '("~11e" 3.14159) " 3.14159E+0") + (test '("~12e" 3.14159) " 3.14159E+0") + (test '("~13,6,2,-5e" 3.14159) " 0.000003E+06") + (test '("~13,6,2,-4e" 3.14159) " 0.000031E+05") + (test '("~13,6,2,-3e" 3.14159) " 0.000314E+04") + (test '("~13,6,2,-2e" 3.14159) " 0.003142E+03") + (test '("~13,6,2,-1e" 3.14159) " 0.031416E+02") + (test '("~13,6,2,0e" 3.14159) " 0.314159E+01") + (test '("~13,6,2,1e" 3.14159) " 3.141590E+00") + (test '("~13,6,2,2e" 3.14159) " 31.41590E-01") + (test '("~13,6,2,3e" 3.14159) " 314.1590E-02") + (test '("~13,6,2,4e" 3.14159) " 3141.590E-03") + (test '("~13,6,2,5e" 3.14159) " 31415.90E-04") + (test '("~13,6,2,6e" 3.14159) " 314159.0E-05") + (test '("~13,6,2,7e" 3.14159) " 3141590.E-06") + (test '("~13,6,2,8e" 3.14159) "31415900.E-07") + (test '("~7,3,,-2e" 0.001) ".001E+0") + (test '("~8,3,,-2@e" 0.001) "+.001E+0") + (test '("~8,3,,-2@e" -0.001) "-.001E+0") + (test '("~8,3,,-2e" 0.001) "0.001E+0") + (test '("~7,,,-2e" 0.001) "0.00E+0") + (test '("~12,3,1e" 3.14159e12) " 3.142E+12") + (test '("~12,3,1,,'*e" 3.14159e12) "************") + (test '("~5,3,1e" 3.14159e12) "3.142E+12") +)) + +; general floating point (this test is from Steele's CL book) + +(cond + (format:floats + (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" + 0.0314159 0.0314159 0.0314159 0.0314159) + " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2") + (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" + 0.314159 0.314159 0.314159 0.314159) + " 0.31 |0.314 |0.314 | 0.31 ") + (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" + 3.14159 3.14159 3.14159 3.14159) + " 3.1 | 3.14 | 3.14 | 3.1 ") + (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" + 31.4159 31.4159 31.4159 31.4159) + " 31. | 31.4 | 31.4 | 31. ") + (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" + 314.159 314.159 314.159 314.159) + " 3.14E+2| 314. | 314. | 3.14E+2") + (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" + 3141.59 3141.59 3141.59 3141.59) + " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3") + (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" + 3.14E12 3.14E12 3.14E12 3.14E12) + "*********|314.0$+10|0.314E+13| 3.14E+12") + (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" + 3.14E120 3.14E120 3.14E120 3.14E120) + "*********|?????????|%%%%%%%%%|3.14E+120") + + (test '("~g" 0.0) "0.0 ") ; further ~g tests + (test '("~g" 0.1) "0.1 ") + (test '("~g" 0.01) "1.0E-2") + (test '("~g" 123.456) "123.456 ") + (test '("~g" 123456.7) "123456.7 ") + (test '("~g" 123456.78) "123456.78 ") + (test '("~g" 0.9282) "0.9282 ") + (test '("~g" 0.09282) "9.282E-2") + (test '("~g" 1) "1.0 ") + (test '("~g" 12) "12.0 ") + )) + +; dollar floating point + +(cond + (format:floats + (test '("~$" 1.23) "1.23") + (test '("~$" 1.2) "1.20") + (test '("~$" 0.0) "0.00") + (test '("~$" 9.999) "10.00") + (test '("~3$" 9.9999) "10.000") + (test '("~,4$" 3.2) "0003.20") + (test '("~,4$" 10000.2) "10000.20") + (test '("~,4,10$" 3.2) " 0003.20") + (test '("~,4,10@$" 3.2) " +0003.20") + (test '("~,4,10:@$" 3.2) "+ 0003.20") + (test '("~,4,10:$" -3.2) "- 0003.20") + (test '("~,4,10$" -3.2) " -0003.20") + (test '("~,,10@$" 3.2) " +3.20") + (test '("~,,10:@$" 3.2) "+ 3.20") + (test '("~,,10:@$" -3.2) "- 3.20") + (test '("~,,10,'_@$" 3.2) "_____+3.20") + (test '("~,,4$" 1234.4) "1234.40") +)) + +; complex numbers + +(cond + (format:complex-numbers + (test '("~i" 3.0) "3.0+0.0i") + (test '("~,3i" 3.0) "3.000+0.000i") + (test `("~7,2i" ,(string->number "3.0+5.0i")) " 3.00 +5.00i") + (test `("~7,2,1i" ,(string->number "3.0+5.0i")) " 30.00 +50.00i") + (test `("~7,2@i" ,(string->number "3.0+5.0i")) " +3.00 +5.00i") + (test `("~7,2,,,'*@i" ,(string->number "3.0+5.0i")) "**+3.00**+5.00i") + )) ; note: some parsers choke syntactically on reading a complex + ; number though format:complex is #f; this is why we put them in + ; strings + +; inquiry test + +(test '("~:q") format:version) + +(if (not test-verbose) (display "done.")) + +(format #t "~%~a Test~:p completed. (~a failure~:p)~2%" total fails) + +; eof diff --git a/gambit.init b/gambit.init new file mode 100644 index 0000000..47717dc --- /dev/null +++ b/gambit.init @@ -0,0 +1,219 @@ +;;;"gambit.init" Initialisation for SLIB for Gambit -*-scheme-*- +;;; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; Updated 1992 February 1 for Gambit v1.71 -- by Ken Dickey +;;; Date: Wed, 12 Jan 1994 15:03:12 -0500 +;;; From: barnett@armadillo.urich.edu (Lewis Barnett) +;;; Relative pathnames for Slib in MacGambit + +(define (SOFTWARE-TYPE) 'UNIX) ; 'MACOS for MacGambit. + +(define (scheme-implementation-type) 'gambit) + +(define (scheme-implementation-version) "?") + +(define SYSTEM ##unix-system) ; Comment out for 'MACOS + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. + +(define implementation-vicinity + (let ((arg0 (vector-ref ##argv 0))) + (let loop ((i (- (string-length arg0) 1))) + (cond ((negative? i) "") + ((char=? #\: (string-ref arg0 i)) + (lambda () + (substring arg0 0 (+ i 1)))) + (else (loop (- i 1))))))) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +;;; This assumes that the slib files are in a folder +;;; called slib in the same directory as the MacGambit Interpreter. + +(define library-vicinity + (let ((library-path + (case (software-type) + ((UNIX) "/usr/local/lib/slib/") + ((MACOS) (string-append (implementation-vicinity) ":slib:")) + ((AMIGA) "dh0:scm/Library/") + ((VMS) "lib$scheme:") + ((MS-DOS) "C:\\SLIB\\") + (else "")))) + (lambda () library-path))) + +;;; *features* should be set to a list of symbols describing features +;;; of this implementation. See Template.scm for the list of feature +;;; names. + +(define *features* + ((lambda (l) + (if (eq? (SOFTWARE-TYPE) 'MACOS) l (cons 'system l))) + '( + source ;can load scheme source files + ;(slib:load-source "filename") + compiled ;can load compiled files + ;(slib:load-compiled "filename") + rev4-report + ieee-p1178 + sicp + rev4-optional-procedures + rev3-procedures + rev2-procedures + multiarg/and- + multiarg-apply + object-hash + rationalize + delay + with-file + transcript + char-ready? + ieee-floating-point + full-continuation + ))) + +;;; (OUTPUT-PORT-WIDTH ) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT ) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +(define current-error-port + (let ((port (current-output-port))) + (lambda () port))) + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam + (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (let ((tmp (string-append "slib_" (number->string cntr)))) + (if (file-exists? tmp) (tmpnam) tmp))))) + +;;; FORCE-OUTPUT flushes any pending output on optional arg output port +;;; use this definition if your system doesn't have such a procedure. +(define (force-output . arg) #t) + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +(define char-code-limit 256) + +;; MOST-POSITIVE-FIXNUM is used in modular.scm +(define most-positive-fixnum #x1FFFFFFF) ;; 3-bit tag for 68K + +;;; Return argument +(define (identity x) x) + +;;; If your implementation provides eval, SLIB:EVAL is single argument +;;; eval using the top-level (user) environment. +(define SLIB:EVAL ##eval-global);; Gambit v1.71 + +;;; If your implementation provides R4RS macros: +;(define macro:eval slib:eval) +;(define macro:load load) + +(define *defmacros* + (list (cons 'defmacro + (lambda (name parms . body) + `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) + *defmacros*)))))) +(define (defmacro? m) (and (assq m *defmacros*) #t)) + +(define (macroexpand-1 e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) (set! a (assq a *defmacros*)) + (if a (apply (cdr a) (cdr e)) e)) + (else e))) + e)) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) + (set! a (assq a *defmacros*)) + (if a (macroexpand (apply (cdr a) (cdr e))) e)) + (else e))) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +(define base:eval slib:eval) +(define (defmacro:eval x) (base:eval (defmacro:expand* x))) +(define (defmacro:expand* x) + (require 'defmacroexpand) (apply defmacro:expand* x '())) + +(define (defmacro:load ) + (slib:eval-load defmacro:eval)) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;; define an error procedure for the library +(define SLIB:ERROR error) + +;; define these as appropriate for your system. +(define slib:tab (integer->char 9)) +(define slib:form-feed (integer->char 12)) + +(define (1+ n) (+ n 1)) +(define (-1+ n) (- n 1)) +(define 1- -1+) + +(define in-vicinity string-append) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:exit (lambda args (exit))) + +;;; Here for backward compatability + +(define (scheme-file-suffix) ".scm") + +;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;; suffix all the module files in SLIB have. See feature 'SOURCE. + +(define slib:load-source load) + +;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;; by compiling "foo.scm" if this implementation can compile files. +;;; See feature 'COMPILED. + +(define slib:load-compiled load) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) + +(slib:load (in-vicinity (library-vicinity) "require")) +;;; --- E O F --- diff --git a/genwrite.scm b/genwrite.scm new file mode 100644 index 0000000..0bb4e56 --- /dev/null +++ b/genwrite.scm @@ -0,0 +1,264 @@ +;;"genwrite.scm" generic write used by pretty-print and truncated-print. +;; Copyright (c) 1991, Marc Feeley +;; Author: Marc Feeley (feeley@iro.umontreal.ca) +;; Distribution restrictions: none + +(define (generic-write obj display? width output) + + (define (read-macro? l) + (define (length1? l) (and (pair? l) (null? (cdr l)))) + (let ((head (car l)) (tail (cdr l))) + (case head + ((QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING) (length1? tail)) + (else #f)))) + + (define (read-macro-body l) + (cadr l)) + + (define (read-macro-prefix l) + (let ((head (car l)) (tail (cdr l))) + (case head + ((QUOTE) "'") + ((QUASIQUOTE) "`") + ((UNQUOTE) ",") + ((UNQUOTE-SPLICING) ",@")))) + + (define (out str col) + (and col (output str) (+ col (string-length str)))) + + (define (wr obj col) + + (define (wr-expr expr col) + (if (read-macro? expr) + (wr (read-macro-body expr) (out (read-macro-prefix expr) col)) + (wr-lst expr col))) + + (define (wr-lst l col) + (if (pair? l) + (let loop ((l (cdr l)) + (col (and col (wr (car l) (out "(" col))))) + (cond ((not col) col) + ((pair? l) + (loop (cdr l) (wr (car l) (out " " col)))) + ((null? l) (out ")" col)) + (else (out ")" (wr l (out " . " col)))))) + (out "()" col))) + + (cond ((pair? obj) (wr-expr obj col)) + ((null? obj) (wr-lst obj col)) + ((vector? obj) (wr-lst (vector->list obj) (out "#" col))) + ((boolean? obj) (out (if obj "#t" "#f") col)) + ((number? obj) (out (number->string obj) col)) + ((symbol? obj) (out (symbol->string obj) col)) + ((procedure? obj) (out "#[procedure]" col)) + ((string? obj) (if display? + (out obj col) + (let loop ((i 0) (j 0) (col (out "\"" col))) + (if (and col (< j (string-length obj))) + (let ((c (string-ref obj j))) + (if (or (char=? c #\\) + (char=? c #\")) + (loop j + (+ j 1) + (out "\\" + (out (substring obj i j) + col))) + (loop i (+ j 1) col))) + (out "\"" + (out (substring obj i j) col)))))) + ((char? obj) (if display? + (out (make-string 1 obj) col) + (out (case obj + ((#\space) "space") + ((#\newline) "newline") + (else (make-string 1 obj))) + (out "#\\" col)))) + ((input-port? obj) (out "#[input-port]" col)) + ((output-port? obj) (out "#[output-port]" col)) + ((eof-object? obj) (out "#[eof-object]" col)) + (else (out "#[unknown]" col)))) + + (define (pp obj col) + + (define (spaces n col) + (if (> n 0) + (if (> n 7) + (spaces (- n 8) (out " " col)) + (out (substring " " 0 n) col)) + col)) + + (define (indent to col) + (and col + (if (< to col) + (and (out (make-string 1 #\newline) col) (spaces to 0)) + (spaces (- to col) col)))) + + (define (pr obj col extra pp-pair) + (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines + (let ((result '()) + (left (min (+ (- (- width col) extra) 1) max-expr-width))) + (generic-write obj display? #f + (lambda (str) + (set! result (cons str result)) + (set! left (- left (string-length str))) + (> left 0))) + (if (> left 0) ; all can be printed on one line + (out (reverse-string-append result) col) + (if (pair? obj) + (pp-pair obj col extra) + (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) + (wr obj col))) + + (define (pp-expr expr col extra) + (if (read-macro? expr) + (pr (read-macro-body expr) + (out (read-macro-prefix expr) col) + extra + pp-expr) + (let ((head (car expr))) + (if (symbol? head) + (let ((proc (style head))) + (if proc + (proc expr col extra) + (if (> (string-length (symbol->string head)) + max-call-head-width) + (pp-general expr col extra #f #f #f pp-expr) + (pp-call expr col extra pp-expr)))) + (pp-list expr col extra pp-expr))))) + + ; (head item1 + ; item2 + ; item3) + (define (pp-call expr col extra pp-item) + (let ((col* (wr (car expr) (out "(" col)))) + (and col + (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) + + ; (item1 + ; item2 + ; item3) + (define (pp-list l col extra pp-item) + (let ((col (out "(" col))) + (pp-down l col col extra pp-item))) + + (define (pp-down l col1 col2 extra pp-item) + (let loop ((l l) (col col1)) + (and col + (cond ((pair? l) + (let ((rest (cdr l))) + (let ((extra (if (null? rest) (+ extra 1) 0))) + (loop rest + (pr (car l) (indent col2 col) extra pp-item))))) + ((null? l) + (out ")" col)) + (else + (out ")" + (pr l + (indent col2 (out "." (indent col2 col))) + (+ extra 1) + pp-item))))))) + + (define (pp-general expr col extra named? pp-1 pp-2 pp-3) + + (define (tail1 rest col1 col2 col3) + (if (and pp-1 (pair? rest)) + (let* ((val1 (car rest)) + (rest (cdr rest)) + (extra (if (null? rest) (+ extra 1) 0))) + (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) + (tail2 rest col1 col2 col3))) + + (define (tail2 rest col1 col2 col3) + (if (and pp-2 (pair? rest)) + (let* ((val1 (car rest)) + (rest (cdr rest)) + (extra (if (null? rest) (+ extra 1) 0))) + (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) + (tail3 rest col1 col2))) + + (define (tail3 rest col1 col2) + (pp-down rest col2 col1 extra pp-3)) + + (let* ((head (car expr)) + (rest (cdr expr)) + (col* (wr head (out "(" col)))) + (if (and named? (pair? rest)) + (let* ((name (car rest)) + (rest (cdr rest)) + (col** (wr name (out " " col*)))) + (tail1 rest (+ col indent-general) col** (+ col** 1))) + (tail1 rest (+ col indent-general) col* (+ col* 1))))) + + (define (pp-expr-list l col extra) + (pp-list l col extra pp-expr)) + + (define (pp-LAMBDA expr col extra) + (pp-general expr col extra #f pp-expr-list #f pp-expr)) + + (define (pp-IF expr col extra) + (pp-general expr col extra #f pp-expr #f pp-expr)) + + (define (pp-COND expr col extra) + (pp-call expr col extra pp-expr-list)) + + (define (pp-CASE expr col extra) + (pp-general expr col extra #f pp-expr #f pp-expr-list)) + + (define (pp-AND expr col extra) + (pp-call expr col extra pp-expr)) + + (define (pp-LET expr col extra) + (let* ((rest (cdr expr)) + (named? (and (pair? rest) (symbol? (car rest))))) + (pp-general expr col extra named? pp-expr-list #f pp-expr))) + + (define (pp-BEGIN expr col extra) + (pp-general expr col extra #f #f #f pp-expr)) + + (define (pp-DO expr col extra) + (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr)) + + ; define formatting style (change these to suit your style) + + (define indent-general 2) + + (define max-call-head-width 5) + + (define max-expr-width 50) + + (define (style head) + (case head + ((LAMBDA LET* LETREC DEFINE) pp-LAMBDA) + ((IF SET!) pp-IF) + ((COND) pp-COND) + ((CASE) pp-CASE) + ((AND OR) pp-AND) + ((LET) pp-LET) + ((BEGIN) pp-BEGIN) + ((DO) pp-DO) + (else #f))) + + (pr obj col 0 pp-expr)) + + (if width + (out (make-string 1 #\newline) (pp obj 0)) + (wr obj 0))) + +; (reverse-string-append l) = (apply string-append (reverse l)) + +(define (reverse-string-append l) + + (define (rev-string-append l i) + (if (pair? l) + (let* ((str (car l)) + (len (string-length str)) + (result (rev-string-append (cdr l) (+ i len)))) + (let loop ((j 0) (k (- (- (string-length result) i) len))) + (if (< j len) + (begin + (string-set! result k (string-ref str j)) + (loop (+ j 1) (+ k 1))) + result))) + (make-string i))) + + (rev-string-append l 0)) diff --git a/getopt.scm b/getopt.scm new file mode 100644 index 0000000..c2962db --- /dev/null +++ b/getopt.scm @@ -0,0 +1,80 @@ +;;; "getopt.scm" POSIX command argument processing +;Copyright (C) 1993, 1994 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define getopt:scan #f) +(define getopt:char #\-) +(define getopt:opt #f) +(define *optind* 1) +(define *optarg* 0) + +(define (getopt argc argv optstring) + (let ((opts (string->list optstring)) + (place #f) + (arg #f) + (argref (lambda () ((if (vector? argv) vector-ref list-ref) + argv *optind*)))) + (and + (cond ((and getopt:scan (not (string=? "" getopt:scan))) #t) + ((>= *optind* argc) #f) + (else + (set! arg (argref)) + (cond ((or (<= (string-length arg) 1) + (not (char=? (string-ref arg 0) getopt:char))) + #f) + ((and (= (string-length arg) 2) + (char=? (string-ref arg 1) getopt:char)) + (set! *optind* (+ *optind* 1)) + #f) + (else + (set! getopt:scan + (substring arg 1 (string-length arg))) + #t)))) + (begin + (set! getopt:opt (string-ref getopt:scan 0)) + (set! getopt:scan + (substring getopt:scan 1 (string-length getopt:scan))) + (if (string=? "" getopt:scan) (set! *optind* (+ *optind* 1))) + (set! place (member getopt:opt opts)) + (cond ((not place) #\?) + ((or (null? (cdr place)) (not (char=? #\: (cadr place)))) + getopt:opt) + ((not (string=? "" getopt:scan)) + (set! *optarg* getopt:scan) + (set! *optind* (+ *optind* 1)) + (set! getopt:scan #f) + getopt:opt) + ((< *optind* argc) + (set! *optarg* (argref)) + (set! *optind* (+ *optind* 1)) + getopt:opt) + ((and (not (null? opts)) (char=? #\: (car opts))) #\:) + (else #\?)))))) + +(define (getopt-- argc argv optstring) + (let* ((opt (getopt argc argv (string-append optstring "-:"))) + (optarg *optarg*)) + (cond ((eqv? #\- opt) ;long option + (do ((l (string-length *optarg*)) + (i 0 (+ 1 i))) + ((or (>= i l) (char=? #\= (string-ref optarg i))) + (cond + ((>= i l) (set! *optarg* #f) optarg) + (else (set! *optarg* (substring optarg (+ 1 i) l)) + (substring optarg 0 i)))))) + (else opt)))) diff --git a/hash.scm b/hash.scm new file mode 100644 index 0000000..ab02138 --- /dev/null +++ b/hash.scm @@ -0,0 +1,153 @@ +; "hash.scm", hashing functions for Scheme. +; Copyright (c) 1992, 1993, 1995 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define (hash:hash-char-ci char n) + (modulo (char->integer (char-downcase char)) n)) + +(define hash:hash-char hash:hash-char-ci) + +(define (hash:hash-symbol sym n) + (hash:hash-string (symbol->string sym) n)) + +;;; This can overflow on implemenatations where inexacts have a larger +;;; range than exact integers. +(define hash:hash-number + (if (provided? 'inexact) + (lambda (num n) + (if (integer? num) + (modulo (if (exact? num) num (inexact->exact num)) n) + (hash:hash-string-ci + (number->string (if (exact? num) (exact->inexact num) num)) + n))) + (lambda (num n) + (if (integer? num) + (modulo num n) + (hash:hash-string-ci (number->string num) n))))) + +(define (hash:hash-string-ci str n) + (let ((len (string-length str))) + (if (> len 5) + (let loop ((h (modulo 264 n)) (i 5)) + (if (positive? i) + (loop (modulo (+ (* h 256) + (char->integer + (char-downcase + (string-ref str (modulo h len))))) + n) + (- i 1)) + h)) + (let loop ((h 0) (i (- len 1))) + (if (>= i 0) + (loop (modulo (+ (* h 256) + (char->integer + (char-downcase (string-ref str i)))) + n) + (- i 1)) + h))))) + +(define hash:hash-string hash:hash-string-ci) + +(define (hash:hash obj n) + (let hs ((d 10) (obj obj)) + (cond + ((number? obj) (hash:hash-number obj n)) + ((char? obj) (modulo (char->integer (char-downcase obj)) n)) + ((symbol? obj) (hash:hash-symbol obj n)) + ((string? obj) (hash:hash-string obj n)) + ((vector? obj) + (let ((len (vector-length obj))) + (if (> len 5) + (let lp ((h 1) (i (quotient d 2))) + (if (positive? i) + (lp (modulo (+ (* h 256) + (hs 2 (vector-ref obj (modulo h len)))) + n) + (- i 1)) + h)) + (let loop ((h (- n 1)) (i (- len 1))) + (if (>= i 0) + (loop (modulo (+ (* h 256) (hs (quotient d len) + (vector-ref obj i))) + n) + (- i 1)) + h))))) + ((pair? obj) + (if (positive? d) (modulo (+ (hs (quotient d 2) (car obj)) + (hs (quotient d 2) (cdr obj))) + n) + 1)) + (else + (modulo + (cond + ((null? obj) 256) + ((boolean? obj) (if obj 257 258)) + ((eof-object? obj) 259) + ((input-port? obj) 260) + ((output-port? obj) 261) + ((procedure? obj) 262) + ((and (provided? 'RECORD) (record? obj)) + (let* ((rtd (record-type-descriptor obj)) + (fns (record-type-field-names rtd)) + (len (length fns))) + (if (> len 5) + (let lp ((h (modulo 266 n)) (i (quotient d 2))) + (if (positive? i) + (lp (modulo + (+ (* h 256) + (hs 2 ((record-accessor + rtd (list-ref fns (modulo h len))) + obj))) + n) + (- i 1)) + h)) + (let loop ((h (- n 1)) (i (- len 1))) + (if (>= i 0) + (loop (modulo + (+ (* h 256) + (hs (quotient d len) + ((record-accessor + rtd (list-ref fns (modulo h len))) + obj))) + n) + (- i 1)) + h))))) + (else 263)) + n))))) + +(define hash hash:hash) +(define hashv hash:hash) + +;;; Object-hash is somewhat expensive on copying GC systems (like +;;; PC-Scheme and MITScheme). We use it only on strings, pairs, +;;; vectors, and records. This also allows us to use it for both +;;; hashq and hashv. + +(if (provided? 'object-hash) + (set! hashv + (if (provided? 'record) + (lambda (obj k) + (if (or (string? obj) (pair? obj) (vector? obj) (record? obj)) + (modulo (object-hash obj) k) + (hash:hash obj k))) + (lambda (obj k) + (if (or (string? obj) (pair? obj) (vector? obj)) + (modulo (object-hash obj) k) + (hash:hash obj k)))))) + +(define hashq hashv) diff --git a/hashtab.scm b/hashtab.scm new file mode 100644 index 0000000..317efe2 --- /dev/null +++ b/hashtab.scm @@ -0,0 +1,79 @@ +; "hashtab.scm", hash tables for Scheme. +; Copyright (c) 1992, 1993 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'hash) +(require 'alist) + +(define (predicate->hash pred) + (cond ((eq? pred eq?) hashq) + ((eq? pred eqv?) hashv) + ((eq? pred equal?) hash) + ((eq? pred =) hashv) + ((eq? pred char=?) hashv) + ((eq? pred char-ci=?) hashv) + ((eq? pred string=?) hash) + ((eq? pred string-ci=?) hash) + (else (slib:error "unknown predicate for hash" pred)))) + +(define (make-hash-table k) (make-vector k '())) + +(define (predicate->hash-asso pred) + (let ((hashfun (predicate->hash pred)) + (asso (predicate->asso pred))) + (lambda (key hashtab) + (asso key + (vector-ref hashtab (hashfun key (vector-length hashtab))))))) + +(define (hash-inquirer pred) + (let ((hashfun (predicate->hash pred)) + (ainq (alist-inquirer pred))) + (lambda (hashtab key) + (ainq (vector-ref hashtab (hashfun key (vector-length hashtab))) + key)))) + +(define (hash-associator pred) + (let ((hashfun (predicate->hash pred)) + (asso (alist-associator pred))) + (lambda (hashtab key val) + (let* ((num (hashfun key (vector-length hashtab)))) + (vector-set! hashtab num + (asso (vector-ref hashtab num) key val))) + hashtab))) + +(define (hash-remover pred) + (let ((hashfun (predicate->hash pred)) + (arem (alist-remover pred))) + (lambda (hashtab key) + (let* ((num (hashfun key (vector-length hashtab)))) + (vector-set! hashtab num + (arem (vector-ref hashtab num) key))) + hashtab))) + +(define (hash-map proc ht) + (define nht (make-vector (vector-length ht))) + (do ((i (+ -1 (vector-length ht)) (+ -1 i))) + ((negative? i) nht) + (vector-set! + nht i + (alist-map proc (vector-ref ht i))))) + +(define (hash-for-each proc ht) + (do ((i (+ -1 (vector-length ht)) (+ -1 i))) + ((negative? i)) + (alist-for-each proc (vector-ref ht i)))) diff --git a/lineio.scm b/lineio.scm new file mode 100644 index 0000000..ad8320b --- /dev/null +++ b/lineio.scm @@ -0,0 +1,50 @@ +; "lineio.scm", line oriented input/output functions for Scheme. +; Copyright (c) 1992, 1993 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define (read-line . arg) + (let* ((char (apply read-char arg))) + (if (eof-object? char) + char + (do ((char char (apply read-char arg)) + (clist '() (cons char clist))) + ((or (eof-object? char) (char=? #\newline char)) + (list->string (reverse clist))))))) + +(define (read-line! str . arg) + (let* ((char (apply read-char arg)) + (len (+ -1 (string-length str)))) + (if (eof-object? char) + char + (do ((char char (apply read-char arg)) + (i 0 (+ 1 i))) + ((or (eof-object? char) + (char=? #\newline char) + (>= i len)) + (cond ((or (eof-object? char) (char=? #\newline char)) + i) + (else + (string-set! str i char) + (set! char (apply peek-char arg)) + (if (or (eof-object? char) (char=? #\newline char)) + (+ 1 i) #f)))) + (string-set! str i char))))) + +(define (write-line str . arg) + (apply display str arg) + (apply newline arg)) diff --git a/logical.scm b/logical.scm new file mode 100644 index 0000000..1cc0726 --- /dev/null +++ b/logical.scm @@ -0,0 +1,150 @@ +;;;; "logical.scm", bit access and operations for integers for Scheme +;;; Copyright (C) 1991, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define logical:integer-expt + (if (provided? 'inexact) + expt + (lambda (n k) + (logical:ipow-by-squaring n k 1 *)))) + +(define (logical:ipow-by-squaring x k acc proc) + (cond ((zero? k) acc) + ((= 1 k) (proc acc x)) + (else (logical:ipow-by-squaring (proc x x) + (quotient k 2) + (if (even? k) acc (proc acc x)) + proc)))) + +(define (logical:logand n1 n2) + (cond ((= n1 n2) n1) + ((zero? n1) 0) + ((zero? n2) 0) + (else + (+ (* (logical:logand (logical:ash-4 n1) (logical:ash-4 n2)) 16) + (vector-ref (vector-ref logical:boole-and (modulo n1 16)) + (modulo n2 16)))))) + +(define (logical:logior n1 n2) + (cond ((= n1 n2) n1) + ((zero? n1) n2) + ((zero? n2) n1) + (else + (+ (* (logical:logior (logical:ash-4 n1) (logical:ash-4 n2)) 16) + (- 15 (vector-ref (vector-ref logical:boole-and + (- 15 (modulo n1 16))) + (- 15 (modulo n2 16)))))))) + +(define (logical:logxor n1 n2) + (cond ((= n1 n2) 0) + ((zero? n1) n2) + ((zero? n2) n1) + (else + (+ (* (logical:logxor (logical:ash-4 n1) (logical:ash-4 n2)) 16) + (vector-ref (vector-ref logical:boole-xor (modulo n1 16)) + (modulo n2 16)))))) + +(define (logical:lognot n) (- -1 n)) + +(define (logical:logtest int1 int2) + (not (zero? (logical:logand int1 int2)))) + +(define (logical:logbit? index int) + (logical:logtest (logical:integer-expt 2 index) int)) + +(define (logical:bit-extract n start end) + (logical:logand (- (logical:integer-expt 2 (- end start)) 1) + (logical:ash n (- start)))) + +(define (logical:ash int cnt) + (if (negative? cnt) + (let ((n (logical:integer-expt 2 (- cnt)))) + (if (negative? int) + (+ -1 (quotient (+ 1 int) n)) + (quotient int n))) + (* (logical:integer-expt 2 cnt) int))) + +(define (logical:ash-4 x) + (if (negative? x) + (+ -1 (quotient (+ 1 x) 16)) + (quotient x 16))) + +(define (logical:logcount n) + (cond ((zero? n) 0) + ((negative? n) (logical:logcount (logical:lognot n))) + (else + (+ (logical:logcount (logical:ash-4 n)) + (vector-ref '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4) + (modulo n 16)))))) + +(define (logical:integer-length n) + (case n + ((0 -1) 0) + ((1 -2) 1) + ((2 3 -3 -4) 2) + ((4 5 6 7 -5 -6 -7 -8) 3) + (else (+ 4 (logical:integer-length (logical:ash-4 n)))))) + +(define logical:boole-xor + '#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) + #(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14) + #(2 3 0 1 6 7 4 5 10 11 8 9 14 15 12 13) + #(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12) + #(4 5 6 7 0 1 2 3 12 13 14 15 8 9 10 11) + #(5 4 7 6 1 0 3 2 13 12 15 14 9 8 11 10) + #(6 7 4 5 2 3 0 1 14 15 12 13 10 11 8 9) + #(7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8) + #(8 9 10 11 12 13 14 15 0 1 2 3 4 5 6 7) + #(9 8 11 10 13 12 15 14 1 0 3 2 5 4 7 6) + #(10 11 8 9 14 15 12 13 2 3 0 1 6 7 4 5) + #(11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4) + #(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3) + #(13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2) + #(14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1) + #(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0))) + +(define logical:boole-and + '#(#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) + #(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1) + #(0 0 2 2 0 0 2 2 0 0 2 2 0 0 2 2) + #(0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3) + #(0 0 0 0 4 4 4 4 0 0 0 0 4 4 4 4) + #(0 1 0 1 4 5 4 5 0 1 0 1 4 5 4 5) + #(0 0 2 2 4 4 6 6 0 0 2 2 4 4 6 6) + #(0 1 2 3 4 5 6 7 0 1 2 3 4 5 6 7) + #(0 0 0 0 0 0 0 0 8 8 8 8 8 8 8 8) + #(0 1 0 1 0 1 0 1 8 9 8 9 8 9 8 9) + #(0 0 2 2 0 0 2 2 8 8 10 10 8 8 10 10) + #(0 1 2 3 0 1 2 3 8 9 10 11 8 9 10 11) + #(0 0 0 0 4 4 4 4 8 8 8 8 12 12 12 12) + #(0 1 0 1 4 5 4 5 8 9 8 9 12 13 12 13) + #(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14) + #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))) + +(define logand logical:logand) +(define logior logical:logior) +(define logxor logical:logxor) +(define lognot logical:lognot) +(define logtest logical:logtest) +(define logbit? logical:logbit?) +(define ash logical:ash) +(define logcount logical:logcount) +(define integer-length logical:integer-length) +(define bit-extract logical:bit-extract) +(define ipow-by-squaring logical:ipow-by-squaring) +(define integer-expt logical:integer-expt) diff --git a/macrotst.scm b/macrotst.scm new file mode 100644 index 0000000..b5b5046 --- /dev/null +++ b/macrotst.scm @@ -0,0 +1,54 @@ +;;;"macrotst.scm" Test for R4RS Macros +;;; From Revised^4 Report on the Algorithmic Language Scheme +;;; Editors: William Clinger and Jonathon Rees +; +; We intend this report to belong to the entire Scheme community, and so +; we grant permission to copy it in whole or in part without fee. In +; particular, we encourage implementors of Scheme to use this report as +; a starting point for manuals and other documentation, modifying it as +; necessary. + +;;; To run this code type +;;; (require 'macro) +;;; (macro:load "macrotst.scm") + +(write "this code should print now, outer, and 7") (newline) + +(write + (let-syntax ((when (syntax-rules () + ((when test stmt1 stmt2 ...) + (if test + (begin stmt1 + stmt2 ...)))))) + (let ((if #t)) + (when if (set! if 'now)) + if))) +(newline) +;;; ==> now + +(write + (let ((x 'outer)) + (let-syntax ((m (syntax-rules () ((m) x)))) + (let ((x 'inner)) + (m))))) +(newline) +;;; ==> outer +(write + (letrec-syntax + ((or (syntax-rules () + ((or) #f) + ((or e) e) + ((or e1 e2 ...) + (let ((temp e1)) + (if temp temp (or e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (let odd?) + (if even?)) + (or x + (let temp) + (if y) + y)))) +(newline) +;;; ==> 7 diff --git a/macscheme.init b/macscheme.init new file mode 100644 index 0000000..56c53a2 --- /dev/null +++ b/macscheme.init @@ -0,0 +1,265 @@ +;;;"macscheme.init" Configuration of *features* for MacScheme -*-scheme-*- +;Copyright (C) 1994 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; From: jjb@isye.gatech.edu (John Bartholdi) + +;;; (software-type) should be set to the generic operating system type. +;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. + +(define (software-type) 'MACOS) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. + +(define (scheme-implementation-type) 'MacScheme) + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "4.2") + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. + +(define (implementation-vicinity) "Macintosh.HD:MacScheme 4.2:") + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +(define (library-vicinity) "Macintosh.HD:MacScheme 4.2:slib:") + +;;; *FEATURES* should be set to a list of symbols describing features +;;; of this implementation. Suggestions for features are: + +(define *features* + '( + source ;can load scheme source files + ;(slib:load-source "filename") +; compiled ;can load compiled files + ;(slib:load-compiled "filename") + rev4-report ;conforms to + rev3-report ;conforms to + ieee-p1178 ;conforms to +; sicp ;runs code from Structure and + ;Interpretation of Computer + ;Programs by Abelson and Sussman. + rev4-optional-procedures ;LIST-TAIL, STRING->LIST, + ;LIST->STRING, STRING-COPY, + ;STRING-FILL!, LIST->VECTOR, + ;VECTOR->LIST, and VECTOR-FILL! + rev3-procedures ;LAST-PAIR, T, and NIL +; rev2-procedures ;SUBSTRING-MOVE-LEFT!, + ;SUBSTRING-MOVE-RIGHT!, + ;SUBSTRING-FILL!, + ;STRING-NULL?, APPEND!, 1+, + ;-1+, ?, >=? + multiarg/and- ;/ and - can take more than 2 args. + multiarg-apply ;APPLY can take more than 2 args. + rationalize + delay ;has DELAY and FORCE + with-file ;has WITH-INPUT-FROM-FILE and + ;WITH-OUTPUT-FROM-FILE + string-port ;has CALL-WITH-INPUT-STRING and + ;CALL-WITH-OUTPUT-STRING +; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF +; char-ready? +; macro ;has R4RS high level macros +; defmacro ;has Common Lisp DEFMACRO + eval ;SLIB:EVAL is single argument eval +; record ;has user defined data structures +; values ;proposed multiple values +; dynamic-wind ;proposed dynamic-wind + ieee-floating-point ;conforms to + full-continuation ;can return multiple times +; object-hash ;has OBJECT-HASH + +; sort +; queue ;queues + pretty-print +; object->string +; format +; trace ;has macros: TRACE and UNTRACE + compiler ;has (COMPILER) +; ed ;(ED) is editor +; system ;posix (system ) +; getenv ;posix (getenv ) +; program-arguments ;returns list of strings (argv) +; Xwindows ;X support +; curses ;screen management package +; termcap ;terminal description package +; terminfo ;sysV terminal description + )) + +;;; (OUTPUT-PORT-WIDTH ) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT ) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +(define current-error-port + (let ((port (current-output-port))) + (lambda () port))) + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (string-append "slib_" (number->string cntr))))) + +;;; (FILE-EXISTS? ) +(define (file-exists? f) #f) + +;;; (DELETE-FILE ) +(define (delete-file f) #f) + +;;; FORCE-OUTPUT flushes any pending output on optional arg output port +;;; use this definition if your system doesn't have such a procedure. +(define (force-output . arg) #t) + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-*PUT-FILE. +(define (call-with-output-string f) + (let ((outsp (open-output-string))) + (f outsp) + (let ((s (get-output-string outsp))) + (close-output-port outsp) + s))) + +(define (call-with-input-string s f) + (let* ((insp (open-input-string s)) + (res (f insp))) + (close-input-port insp) + res)) + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +(define char-code-limit 256) + +;;; MOST-POSITIVE-FIXNUM is used in modular.scm +(define most-positive-fixnum 536870911) + +;;; Return argument +(define (identity x) x) + +;;; If your implementation provides eval SLIB:EVAL is single argument +;;; eval using the top-level (user) environment. +(define slib:eval eval) + +;;; If your implementation provides R4RS macros: +;(define macro:eval slib:eval) +;(define macro:load load) + +(define *defmacros* + (list (cons 'defmacro + (lambda (name parms . body) + `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) + *defmacros*)))))) +(define (defmacro? m) (and (assq m *defmacros*) #t)) + +(define (macroexpand-1 e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) (set! a (assq a *defmacros*)) + (if a (apply (cdr a) (cdr e)) e)) + (else e))) + e)) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) + (set! a (assq a *defmacros*)) + (if a (macroexpand (apply (cdr a) (cdr e))) e)) + (else e))) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +(define base:eval slib:eval) +(define (defmacro:eval x) (base:eval (defmacro:expand* x))) +(define (defmacro:expand* x) + (require 'defmacroexpand) (apply defmacro:expand* x '())) + +(define (defmacro:load ) + (slib:eval-load defmacro:eval)) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;;; define an error procedure for the library +(define slib:error + (lambda args + (cerror "Error: " args))) + +;;; define these as appropriate for your system. +(define slib:tab #\tab) +(define slib:form-feed #\page) + +;;; Define these if your implementation's syntax can support it and if +;;; they are not already defined. + +;(define (1+ n) (+ n 1)) +;(define (-1+ n) (+ n -1)) +;(define 1- -1+) + +(define in-vicinity string-append) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +; MacScheme does not return a value when it exits, +; so simply invoke system procedure exit with 0 args. +(define slib:exit (lambda args (exit))) + +;;; Here for backward compatability +(define scheme-file-suffix + (let ((suffix (case (software-type) + ((NOSVE) "_scm") + (else ".scm")))) + (lambda () suffix))) + +;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;; suffix all the module files in SLIB have. See feature 'SOURCE. + +;(define slib:load-source load) +(define (slib:load-source f) (load (string-append f (scheme-file-suffix)))) + +;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;; by compiling "foo.scm" if this implementation can compile files. +;;; See feature 'COMPILED. + +(define slib:load-compiled load) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) + +(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/macwork.scm b/macwork.scm new file mode 100644 index 0000000..6336ae5 --- /dev/null +++ b/macwork.scm @@ -0,0 +1,126 @@ +;;;; "macwork.scm": Will Clinger's macros that work. -*- Scheme -*- +;Copyright 1992 William Clinger +; +; Permission to copy this software, in whole or in part, to use this +; software for any lawful purpose, and to redistribute this software +; is granted subject to the restriction that all copies made of this +; software must include this copyright notice in full. +; +; I also request that you send me a copy of any improvements that you +; make to this software so that they may be incorporated within it to +; the benefit of the Scheme community. + +(slib:load (in-vicinity (program-vicinity) "mwexpand")) + +;;;; Miscellaneous routines. + +(define (mw:warn msg . more) + (display "WARNING from macro expander:") + (newline) + (display msg) + (newline) + (for-each (lambda (x) (write x) (newline)) + more)) + +(define (mw:error msg . more) + (display "ERROR detected during macro expansion:") + (newline) + (display msg) + (newline) + (for-each (lambda (x) (write x) (newline)) + more) + (mw:quit #f)) + +(define (mw:bug msg . more) + (display "BUG in macro expander: ") + (newline) + (display msg) + (newline) + (for-each (lambda (x) (write x) (newline)) + more) + (mw:quit #f)) + +; Given a , returns a list of bound variables. + +(define (mw:make-null-terminated x) + (cond ((null? x) '()) + ((pair? x) + (cons (car x) (mw:make-null-terminated (cdr x)))) + (else (list x)))) + +; Returns the length of the given list, or -1 if the argument +; is not a list. Does not check for circular lists. + +(define (mw:safe-length x) + (define (loop x n) + (cond ((null? x) n) + ((pair? x) (loop (cdr x) (+ n 1))) + (else -1))) + (loop x 0)) + +(require 'common-list-functions) + +; Given an association list, copies the association pairs. + +(define (mw:syntax-copy alist) + (map (lambda (x) (cons (car x) (cdr x))) + alist)) + +;;;; Implementation-dependent parameters and preferences that determine +; how identifiers are represented in the output of the macro expander. +; +; The basic problem is that there are no reserved words, so the +; syntactic keywords of core Scheme that are used to express the +; output need to be represented by data that cannot appear in the +; input. This file defines those data. + +; The following definitions assume that identifiers of mixed case +; cannot appear in the input. + +;(define mw:begin1 (string->symbol "Begin")) +;(define mw:define1 (string->symbol "Define")) +;(define mw:quote1 (string->symbol "Quote")) +;(define mw:lambda1 (string->symbol "Lambda")) +;(define mw:if1 (string->symbol "If")) +;(define mw:set!1 (string->symbol "Set!")) + +(define mw:begin1 'begin) +(define mw:define1 'define) +(define mw:quote1 'quote) +(define mw:lambda1 'lambda) +(define mw:if1 'if) +(define mw:set!1 'set!) + +; The following defines an implementation-dependent expression +; that evaluates to an undefined (not unspecified!) value, for +; use in expanding the (define x) syntax. + +(define mw:undefined (list (string->symbol "Undefined"))) + +; A variable is renamed by suffixing a vertical bar followed by a unique +; integer. In IEEE and R4RS Scheme, a vertical bar cannot appear as part +; of an identifier, but presumably this is enforced by the reader and not +; by the compiler. Any other character that cannot appear as part of an +; identifier may be used instead of the vertical bar. + +(define mw:suffix-character #\|) + +(slib:load (in-vicinity (program-vicinity) "mwdenote")) +(slib:load (in-vicinity (program-vicinity) "mwsynrul")) + +(define macro:expand macwork:expand) + +;;; Here are EVAL, EVAL! and LOAD which expand macros. You can replace the +;;; implementation's eval and load with them if you like. +(define base:eval slib:eval) +(define base:load load) + +(define (macwork:eval x) (base:eval (macwork:expand x))) +(define macro:eval macwork:eval) + +(define (macwork:load ) + (slib:eval-load macwork:eval)) +(define macro:load macwork:load) + +(provide 'macros-that-work) +(provide 'macro) diff --git a/makcrc.scm b/makcrc.scm new file mode 100644 index 0000000..b11f80e --- /dev/null +++ b/makcrc.scm @@ -0,0 +1,86 @@ +;;;; "makcrc.scm" Compute Cyclic Checksums +;;; Copyright (C) 1995, 1996 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;;(define crc (eval (make-port-crc 16 #o010013))) +;;;(define crc (eval (make-port-crc 08 #o053))) + +(define (file-check-sum file) (call-with-input-file file crc32)) + +(define (make-port-crc . margs) + (define (make-mask hibit) + (+ (ash (+ -1 (ash 1 (+ 1 (- hibit 2)))) 1) 1)) + (define accum-bits 32) + (define chunk-bits (integer-length (+ -1 char-code-limit))) + (define generator #f) + (cond ((pair? margs) + (set! accum-bits (car margs)) + (cond ((pair? (cdr margs)) + (set! generator (cadr margs)))))) + (cond ((not generator) + (case accum-bits + ((32) (set! generator #b00000100110000010001110110110111)) + (else (slib:error 'make-port-crc "no default polynomial for" + accum-bits "bits"))))) + (let* ((chunk-mask (make-mask chunk-bits)) + (crctab (make-vector (+ 1 chunk-mask)))) + (define (accum src) + `(set! + crc + (logxor (ash (logand ,(make-mask (- accum-bits chunk-bits)) crc) + ,chunk-bits) + (vector-ref crctab + (logand ,chunk-mask + (logxor + (ash crc ,(- chunk-bits accum-bits)) + ,src)))))) + (define (make-crc-table) + (letrec ((r (make-vector chunk-bits)) + (remd (lambda (m) + (define rem 0) + (do ((i 0 (+ 1 i))) + ((>= i chunk-bits) rem) + (if (logbit? i m) + (set! rem (logxor rem (vector-ref r i)))))))) + (vector-set! r 0 generator) + (do ((i 1 (+ 1 i))) + ((>= i chunk-bits)) + (let ((r-1 (vector-ref r (+ -1 i))) + (m-1 (make-mask (+ -1 accum-bits)))) + (vector-set! r i (if (logbit? (+ -1 accum-bits) r-1) + (logxor (ash (logand m-1 r-1) 1) generator) + (ash (logand m-1 r-1) 1))))) + (do ((i 0 (+ 1 i))) + ((> i chunk-mask)) + (vector-set! crctab i (remd i))))) + (cond ((>= (integer-length generator) accum-bits) + (slib:error 'make-port-crc + "generator longer than" accum-bits "bits"))) + (make-crc-table) + `(lambda (port) + (define crc 0) + (define byte-count 0) + (define crctab ,crctab) + (do ((ci (read-char port) (read-char port))) + ((eof-object? ci)) + ,(accum '(char->integer ci)) + (set! byte-count (+ 1 byte-count))) + (do ((byte-count byte-count (ash byte-count ,(- chunk-bits)))) + ((zero? byte-count)) + ,(accum 'byte-count)) + (logxor ,(make-mask accum-bits) crc)))) diff --git a/mbe.scm b/mbe.scm new file mode 100644 index 0000000..e48e1f1 --- /dev/null +++ b/mbe.scm @@ -0,0 +1,362 @@ +;;;; "mbe.scm" "Macro by Example" (Eugene Kohlbecker, r4rs) +;;; From: Dorai Sitaram, dorai@cs.rice.edu, 1991, revised Sept. 3, 1992, +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; revised Dec. 6, 1993 to r4rs syntax (if not semantics). +;;; revised Mar. 2 1994 for SLIB (jaffer@ai.mit.edu). + +;;; A vanilla implementation of Macro-by-Example (Eugene +;;; Kohlbecker, r4rs). This file requires defmacro. + +(require 'common-list-functions) ;nconc, some, every +;(require 'rev2-procedures) ;append! alternate for nconc +(require 'rev4-optional-procedures) ;list-tail +(require 'defmacroexpand) + +;;; A vanilla implementation of a hygiene filter for define-syntax + +;(define hyg:tag-generic +; (lambda (e kk tmps) e)) + +;;; if you don't want the hygiene filter, comment out the following +;;; s-exp and uncomment the previous one. + +(define hyg:tag-generic + (lambda (e kk tmps) + (if (pair? e) + (let ((a (car e))) + (case a + ((quote) `(quote ,(hyg:tag-vanilla (cadr e) kk tmps))) + ((if begin) + `(,a ,@(map (lambda (e1) (hyg:tag-generic e1 kk tmps)) + (cdr e)))) + ((set! define) + `(,a ,(hyg:tag-vanilla (cadr e) kk tmps) + ,@(map (lambda (e1) (hyg:tag-generic e1 kk tmps)) + (cddr e)))) + ((lambda) (hyg:tag-lambda (cdr e) kk tmps)) + ((letrec) (hyg:tag-letrec (cdr e) kk tmps)) + ((let) (hyg:tag-let (cdr e) kk tmps)) + ((let*) (hyg:tag-let-star (cdr e) kk tmps)) + ((do) (hyg:tag-do (cdr e) kk tmps)) + ((case) + `(case ,(hyg:tag-generic (cadr e) kk tmps) + ,@(map + (lambda (cl) + `(,(hyg:tag-vanilla (car cl) kk tmps) + ,@(map + (lambda (e1) + (hyg:tag-generic e1 kk tmps)) + (cdr cl)))) + (cddr e)))) + ((cond) + `(cond ,@(map + (lambda (cl) + (map (lambda (e1) + (hyg:tag-generic e1 kk tmps)) + cl)) + (cdr e)))) + (else (map (lambda (e1) + (hyg:tag-generic e1 kk tmps)) + e)))) + (hyg:tag-vanilla e kk tmps)))) + +(define hyg:tag-vanilla + (lambda (e kk tmps) + (cond ((symbol? e) + (cond ((memq e kk) e) + ((assq e tmps) => cdr) + (else e))) + ((pair? e) + (cons (hyg:tag-vanilla (car e) kk tmps) + (hyg:tag-vanilla (cdr e) kk tmps))) + (else e)))) + +(define hyg:tag-lambda + (lambda (e kk tmps) + (let* ((bvv (car e)) + (tmps2 (append + (map (lambda (v) (cons v (gentemp))) + (hyg:flatten bvv)) + tmps))) + `(lambda + ,(hyg:tag-vanilla bvv kk tmps2) + ,@(map + (lambda (e1) + (hyg:tag-generic e1 kk tmps2)) + (cdr e)))))) + +(define hyg:flatten + (lambda (e) + (let loop ((e e) (r '())) + (cond ((pair? e) (loop (car e) + (loop (cdr e) r))) + ((null? e) r) + (else (cons e r)))))) + +(define hyg:tag-letrec + (lambda (e kk tmps) + (let* ((varvals (car e)) + (tmps2 (append + (map (lambda (v) (cons v (gentemp))) + (map car varvals)) + tmps))) + `(letrec ,(map + (lambda (varval) + `(,(hyg:tag-vanilla (car varval) + kk tmps2) + ,(hyg:tag-generic (cadr varval) + kk tmps2))) + varvals) + ,@(map (lambda (e1) + (hyg:tag-generic e1 kk tmps2)) + (cdr e)))))) + +(define hyg:tag-let + (lambda (e kk tmps) + (let* ((tt (if (symbol? (car e)) (cons (car e) (gentemp)) '())) + (e (if (null? tt) e (cdr e))) + (tmps (if (null? tt) tmps (append (list tt) tmps)))) + (let* ((varvals (car e)) + (tmps2 (append (map (lambda (v) (cons v (gentemp))) + (map car varvals)) + tmps))) + `(let + ,@(if (null? tt) '() `(,(hyg:tag-vanilla (car tt) + kk + tmps))) + ,(let loop ((varvals varvals) + (i (length varvals))) + (if (null? varvals) '() + (let ((varval (car varvals)) + (tmps3 (list-tail tmps2 i))) + (cons `(,(hyg:tag-vanilla (car varval) + kk tmps2) + ,(hyg:tag-generic (cadr varval) + kk tmps3)) + (loop (cdr varvals) (- i 1)))))) + ,@(map + (lambda (e1) + (hyg:tag-generic e1 kk tmps2)) + (cdr e))))))) + +(define hyg:tag-do + (lambda (e kk tmps) + (let* ((varinistps (car e)) + (tmps2 (append (map (lambda (v) (cons v (gentemp))) + (map car varinistps)) + tmps))) + `(do + ,(let loop ((varinistps varinistps) + (i (length varinistps))) + (if (null? varinistps) '() + (let ((varinistp (car varinistps)) + (tmps3 (list-tail tmps2 i))) + (cons `(,(hyg:tag-vanilla (car varinistp) + kk tmps2) + ,(hyg:tag-generic (cadr varinistp) + kk tmps3) + ,@(hyg:tag-generic (cddr varinistp) + kk tmps2)) + (loop (cdr varinistps) (- i 1)))))) + ,(map (lambda (e1) + (hyg:tag-generic e1 kk tmps2)) (cadr e)) + ,@(map + (lambda (e1) + (hyg:tag-generic e1 kk tmps2)) + (cddr e)))))) + +(define hyg:tag-let-star + (lambda (e kk tmps) + (let* ((varvals (car e)) + (tmps2 (append (reverse (map (lambda (v) (cons v (gentemp))) + (map car varvals))) + tmps))) + `(let* + ,(let loop ((varvals varvals) + (i (- (length varvals) 1))) + (if (null? varvals) '() + (let ((varval (car varvals)) + (tmps3 (list-tail tmps2 i))) + (cons `(,(hyg:tag-vanilla (car varval) + kk tmps3) + ,(hyg:tag-generic (cadr varval) + kk (cdr tmps3))) + (loop (cdr varvals) (- i 1)))))) + ,@(map + (lambda (e1) + (hyg:tag-generic e1 kk tmps2)) + (cdr e)))))) + +;;;; End of hygiene filter. + +;;; finds the leftmost index of list l where something equal to x +;;; occurs +(define mbe:position + (lambda (x l) + (let loop ((l l) (i 0)) + (cond ((not (pair? l)) #f) + ((equal? (car l) x) i) + (else (loop (cdr l) (+ i 1))))))) + +;;; tests if expression e matches pattern p where k is the list of +;;; keywords +(define mbe:matches-pattern? + (lambda (p e k) + (cond ((mbe:ellipsis? p) + (and (or (null? e) (pair? e)) + (let* ((p-head (car p)) + (p-tail (cddr p)) + (e-head=e-tail (mbe:split-at-ellipsis e p-tail))) + (and e-head=e-tail + (let ((e-head (car e-head=e-tail)) + (e-tail (cdr e-head=e-tail))) + (and (comlist:every + (lambda (x) (mbe:matches-pattern? p-head x k)) + e-head) + (mbe:matches-pattern? p-tail e-tail k))))))) + ((pair? p) + (and (pair? e) + (mbe:matches-pattern? (car p) (car e) k) + (mbe:matches-pattern? (cdr p) (cdr e) k))) + ((symbol? p) (if (memq p k) (eq? p e) #t)) + (else (equal? p e))))) + +;;; gets the bindings of pattern variables of pattern p for +;;; expression e; +;;; k is the list of keywords +(define mbe:get-bindings + (lambda (p e k) + (cond ((mbe:ellipsis? p) + (let* ((p-head (car p)) + (p-tail (cddr p)) + (e-head=e-tail (mbe:split-at-ellipsis e p-tail)) + (e-head (car e-head=e-tail)) + (e-tail (cdr e-head=e-tail))) + (cons (cons (mbe:get-ellipsis-nestings p-head k) + (map (lambda (x) (mbe:get-bindings p-head x k)) + e-head)) + (mbe:get-bindings p-tail e-tail k)))) + ((pair? p) + (append (mbe:get-bindings (car p) (car e) k) + (mbe:get-bindings (cdr p) (cdr e) k))) + ((symbol? p) + (if (memq p k) '() (list (cons p e)))) + (else '())))) + +;;; expands pattern p using environment r; +;;; k is the list of keywords +(define mbe:expand-pattern + (lambda (p r k) + (cond ((mbe:ellipsis? p) + (append (let* ((p-head (car p)) + (nestings (mbe:get-ellipsis-nestings p-head k)) + (rr (mbe:ellipsis-sub-envs nestings r))) + (map (lambda (r1) + (mbe:expand-pattern p-head (append r1 r) k)) + rr)) + (mbe:expand-pattern (cddr p) r k))) + ((pair? p) + (cons (mbe:expand-pattern (car p) r k) + (mbe:expand-pattern (cdr p) r k))) + ((symbol? p) + (if (memq p k) p + (let ((x (assq p r))) + (if x (cdr x) p)))) + (else p)))) + +;;; returns a list that nests a pattern variable as deeply as it +;;; is ellipsed +(define mbe:get-ellipsis-nestings + (lambda (p k) + (let sub ((p p)) + (cond ((mbe:ellipsis? p) (cons (sub (car p)) (sub (cddr p)))) + ((pair? p) (append (sub (car p)) (sub (cdr p)))) + ((symbol? p) (if (memq p k) '() (list p))) + (else '()))))) + +;;; finds the subenvironments in r corresponding to the ellipsed +;;; variables in nestings +(define mbe:ellipsis-sub-envs + (lambda (nestings r) + (comlist:some (lambda (c) + (if (mbe:contained-in? nestings (car c)) (cdr c) #f)) + r))) + +;;; checks if nestings v and y have an intersection +(define mbe:contained-in? + (lambda (v y) + (if (or (symbol? v) (symbol? y)) (eq? v y) + (comlist:some (lambda (v_i) + (comlist:some (lambda (y_j) + (mbe:contained-in? v_i y_j)) + y)) + v)))) + +;;; split expression e so that its second half matches with +;;; pattern p-tail +(define mbe:split-at-ellipsis + (lambda (e p-tail) + (if (null? p-tail) (cons e '()) + (let ((i (mbe:position (car p-tail) e))) + (if i (cons (butlast e (- (length e) i)) + (list-tail e i)) + (slib:error 'mbe:split-at-ellipsis 'bad-arg)))))) + +;;; tests if x is an ellipsing pattern, i.e., of the form +;;; (blah ... . blah2) +(define mbe:ellipsis? + (lambda (x) + (and (pair? x) (pair? (cdr x)) (eq? (cadr x) '...)))) + +;define-syntax + +(defmacro define-syntax (macro-name syn-rules) + (if (or (not (pair? syn-rules)) + (not (eq? (car syn-rules) 'syntax-rules))) + (slib:error 'define-syntax 'not-an-r4rs-high-level-macro + macro-name syn-rules) + (let ((keywords (cons macro-name (cadr syn-rules))) + (clauses (cddr syn-rules))) + `(defmacro ,macro-name macro-arg + (let ((macro-arg (cons ',macro-name macro-arg)) + (keywords ',keywords)) + (cond ,@(map + (lambda (clause) + (let ((in-pattern (car clause)) + (out-pattern (cadr clause))) + `((mbe:matches-pattern? ',in-pattern macro-arg + keywords) + (hyg:tag-generic + (mbe:expand-pattern + ',out-pattern + (mbe:get-bindings ',in-pattern macro-arg + keywords) + keywords) + (nconc + (hyg:flatten ',in-pattern) + keywords) + '())))) + clauses) + (else (slib:error ',macro-name 'no-matching-clause + ',clauses)))))))) + +(define macro:eval slib:eval) +(define macro:load slib:load) +(provide 'macro) +;eof diff --git a/mitcomp.pat b/mitcomp.pat new file mode 100644 index 0000000..78cb9b9 --- /dev/null +++ b/mitcomp.pat @@ -0,0 +1,1466 @@ +;"mitcomp.pat", patch file of definitions for compiling SLIB with MitScheme. +;;; Copyright (C) 1993 Matthew McDonald. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +From: mafm@cs.uwa.edu.au (Matthew MCDONALD) + + Added declarations to files providing these: +dynamic alist hash hash-table logical random random-inexact modular +prime charplot common-list-functions format generic-write pprint-file +pretty-print-to-string object->string string-case printf line-i/o +synchk priority-queue process red-black-tree sort + +(for-each cf + '("dynamic.scm" "alist.scm" "hash.scm" "hashtab.scm" "logical.scm" + "random.scm" "randinex.scm" "modular.scm" "prime.scm" "charplot.scm" + "comlist.scm" "format.scm" "genwrite.scm" "ppfile.scm" "pp2str.scm" + "obj2str.scm" "strcase.scm" "printf.scm" "lineio.scm" "synchk.scm" + "priorque.scm" "process.scm" "rbtree.scm" "sort.scm)) + +while in the SLIB directory will compile all of these. + + They all appear to still be working... They should be +everything CScheme currently uses (except [1] below.) + +NOTES: + +[1] Not altered: + debug Not worth optimising + test " " " + fluid-let compiler chokes over + (lambda () . body) + scmacro Fails when compiled, not immediately obvious why + synclo " " " + r4rsyn " " " + yasos requires the macros + collect " " " + +[2] removed 'sort from list of MIT features. The library version is +more complete (and needed for charplot.) + +[3] Remember that mitscheme.init gets the .bin put in the wrong place +by the compiler and thus doesn't get recognised by LOAD. +====================================================================== +diff -c slib/alist.scm nlib/alist.scm +*** slib/alist.scm Thu Jan 21 00:01:34 1993 +--- nlib/alist.scm Tue Feb 9 00:21:07 1993 +*************** +*** 44,50 **** + ;(define rem (alist-remover string-ci=?)) + ;(set! alist (rem alist "fOO")) + +! (define (predicate->asso pred) + (cond ((eq? eq? pred) assq) + ((eq? = pred) assv) + ((eq? eqv? pred) assv) +--- 44,53 ---- + ;(define rem (alist-remover string-ci=?)) + ;(set! alist (rem alist "fOO")) + +! ;;; Declarations for CScheme +! (declare (usual-integrations)) +! +! (define-integrable (predicate->asso pred) + (cond ((eq? eq? pred) assq) + ((eq? = pred) assv) + ((eq? eqv? pred) assv) +*************** +*** 57,69 **** + ((pred key (caar al)) (car al)) + (else (l (cdr al))))))))) + +! (define (alist-inquirer pred) + (let ((assofun (predicate->asso pred))) + (lambda (alist key) + (let ((pair (assofun key alist))) + (and pair (cdr pair)))))) + +! (define (alist-associator pred) + (let ((assofun (predicate->asso pred))) + (lambda (alist key val) + (let* ((pair (assofun key alist))) +--- 60,72 ---- + ((pred key (caar al)) (car al)) + (else (l (cdr al))))))))) + +! (define-integrable (alist-inquirer pred) + (let ((assofun (predicate->asso pred))) + (lambda (alist key) + (let ((pair (assofun key alist))) + (and pair (cdr pair)))))) + +! (define-integrable (alist-associator pred) + (let ((assofun (predicate->asso pred))) + (lambda (alist key val) + (let* ((pair (assofun key alist))) +*************** +*** 71,77 **** + alist) + (else (cons (cons key val) alist))))))) + +! (define (alist-remover pred) + (lambda (alist key) + (cond ((null? alist) alist) + ((pred key (caar alist)) (cdr alist)) +--- 74,80 ---- + alist) + (else (cons (cons key val) alist))))))) + +! (define-integrable (alist-remover pred) + (lambda (alist key) + (cond ((null? alist) alist) + ((pred key (caar alist)) (cdr alist)) +diff -c slib/charplot.scm nlib/charplot.scm +*** slib/charplot.scm Sat Nov 14 21:50:54 1992 +--- nlib/charplot.scm Tue Feb 9 00:21:07 1993 +*************** +*** 7,12 **** +--- 7,24 ---- + ;are strings with names to label the x and y axii with. + + ;;;;--------------------------------------------------------------- ++ ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ (declare (integrate-external "sort")) ++ (declare (integrate ++ rows ++ columns ++ charplot:height ++ charplot:width ++ charplot:plot ++ plot!)) ++ + (require 'sort) + + (define rows 24) +*************** +*** 27,39 **** + (write-char char) + (charplot:printn! (+ n -1) char)))) + +! (define (charplot:center-print! str width) + (let ((lpad (quotient (- width (string-length str)) 2))) + (charplot:printn! lpad #\ ) + (display str) + (charplot:printn! (- width (+ (string-length str) lpad)) #\ ))) + +! (define (scale-it z scale) + (if (and (exact? z) (integer? z)) + (quotient (* z (car scale)) (cadr scale)) + (inexact->exact (round (/ (* z (car scale)) (cadr scale)))))) +--- 39,51 ---- + (write-char char) + (charplot:printn! (+ n -1) char)))) + +! (define-integrable (charplot:center-print! str width) + (let ((lpad (quotient (- width (string-length str)) 2))) + (charplot:printn! lpad #\ ) + (display str) + (charplot:printn! (- width (+ (string-length str) lpad)) #\ ))) + +! (define-integrable (scale-it z scale) + (if (and (exact? z) (integer? z)) + (quotient (* z (car scale)) (cadr scale)) + (inexact->exact (round (/ (* z (car scale)) (cadr scale)))))) +diff -c slib/comlist.scm nlib/comlist.scm +*** slib/comlist.scm Wed Jan 27 11:08:44 1993 +--- nlib/comlist.scm Tue Feb 9 00:21:08 1993 +*************** +*** 6,11 **** +--- 6,14 ---- + + ;;;; LIST FUNCTIONS FROM COMMON LISP + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ + ;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) + (define (make-list k . init) + (set! init (if (pair? init) (car init))) +*************** +*** 13,21 **** + (result '() (cons init result))) + ((<= k 0) result))) + +! (define (copy-list lst) (append lst '())) + +! (define (adjoin e l) (if (memq e l) l (cons e l))) + + (define (union l1 l2) + (cond ((null? l1) l2) +--- 16,24 ---- + (result '() (cons init result))) + ((<= k 0) result))) + +! (define-integrable (copy-list lst) (append lst '())) + +! (define-integrable (adjoin e l) (if (memq e l) l (cons e l))) + + (define (union l1 l2) + (cond ((null? l1) l2) +*************** +*** 33,39 **** + ((memv (car l1) l2) (set-difference (cdr l1) l2)) + (else (cons (car l1) (set-difference (cdr l1) l2))))) + +! (define (position obj lst) + (letrec ((pos (lambda (n lst) + (cond ((null? lst) #f) + ((eqv? obj (car lst)) n) +--- 36,42 ---- + ((memv (car l1) l2) (set-difference (cdr l1) l2)) + (else (cons (car l1) (set-difference (cdr l1) l2))))) + +! (define-integrable (position obj lst) + (letrec ((pos (lambda (n lst) + (cond ((null? lst) #f) + ((eqv? obj (car lst)) n) +*************** +*** 45,51 **** + init + (reduce-init p (p init (car l)) (cdr l)))) + +! (define (reduce p l) + (cond ((null? l) l) + ((null? (cdr l)) (car l)) + (else (reduce-init p (car l) (cdr l))))) +--- 48,54 ---- + init + (reduce-init p (p init (car l)) (cdr l)))) + +! (define-integrable (reduce p l) + (cond ((null? l) l) + ((null? (cdr l)) (car l)) + (else (reduce-init p (car l) (cdr l))))) +*************** +*** 58,64 **** + (or (null? l) + (and (pred (car l)) (every pred (cdr l))))) + +! (define (notevery pred l) (not (every pred l))) + + (define (find-if t l) + (cond ((null? l) #f) +--- 61,67 ---- + (or (null? l) + (and (pred (car l)) (every pred (cdr l))))) + +! (define-integrable (notevery pred l) (not (every pred l))) + + (define (find-if t l) + (cond ((null? l) #f) +*************** +*** 121,141 **** + (define (nthcdr n lst) + (if (zero? n) lst (nthcdr (+ -1 n) (cdr lst)))) + +! (define (last lst n) + (nthcdr (- (length lst) n) lst)) + + ;;;; CONDITIONALS + +! (define (and? . args) + (cond ((null? args) #t) + ((car args) (apply and? (cdr args))) + (else #f))) + +! (define (or? . args) + (cond ((null? args) #f) + ((car args) #t) + (else (apply or? (cdr args))))) + +! (define (identity x) x) + + (require 'rev3-procedures) +--- 124,144 ---- + (define (nthcdr n lst) + (if (zero? n) lst (nthcdr (+ -1 n) (cdr lst)))) + +! (define-integrable (last lst n) + (nthcdr (- (length lst) n) lst)) + + ;;;; CONDITIONALS + +! (define-integrable (and? . args) + (cond ((null? args) #t) + ((car args) (apply and? (cdr args))) + (else #f))) + +! (define-integrable (or? . args) + (cond ((null? args) #f) + ((car args) #t) + (else (apply or? (cdr args))))) + +! (define-integrable (identity x) x) + + (require 'rev3-procedures) +diff -c slib/dynamic.scm nlib/dynamic.scm +*** slib/dynamic.scm Thu Sep 17 23:35:46 1992 +--- nlib/dynamic.scm Tue Feb 9 00:21:08 1993 +*************** +*** 31,36 **** +--- 31,43 ---- + ; + ;There was also a DYNAMIC-BIND macro which I haven't implemented. + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ ++ (declare (integrate-external "record")) ++ (declare (integrate-external "dynwind")) ++ (declare (integrate dynamic:errmsg)) ++ + (require 'record) + (require 'dynamic-wind) + +*************** +*** 48,60 **** + (record-accessor dynamic-environment-rtd 'parent)) + + (define *current-dynamic-environment* #f) +! (define (extend-current-dynamic-environment dynamic obj) + (set! *current-dynamic-environment* + (make-dynamic-environment dynamic obj + *current-dynamic-environment*))) + + (define dynamic-rtd (make-record-type "dynamic" '())) +! (define make-dynamic + (let ((dynamic-constructor (record-constructor dynamic-rtd))) + (lambda (obj) + (let ((dynamic (dynamic-constructor))) +--- 55,69 ---- + (record-accessor dynamic-environment-rtd 'parent)) + + (define *current-dynamic-environment* #f) +! +! (define-integrable (extend-current-dynamic-environment dynamic obj) + (set! *current-dynamic-environment* + (make-dynamic-environment dynamic obj + *current-dynamic-environment*))) + + (define dynamic-rtd (make-record-type "dynamic" '())) +! +! (define-integrable make-dynamic + (let ((dynamic-constructor (record-constructor dynamic-rtd))) + (lambda (obj) + (let ((dynamic (dynamic-constructor))) +*************** +*** 61,68 **** + (extend-current-dynamic-environment dynamic obj) + dynamic)))) + +! (define dynamic? (record-predicate dynamic-rtd)) +! (define (guarantee-dynamic dynamic) + (or (dynamic? dynamic) + (slib:error "Not a dynamic" dynamic))) + +--- 70,78 ---- + (extend-current-dynamic-environment dynamic obj) + dynamic)))) + +! (define-integrable dynamic? (record-predicate dynamic-rtd)) +! +! (define-integrable (guarantee-dynamic dynamic) + (or (dynamic? dynamic) + (slib:error "Not a dynamic" dynamic))) + +*************** +*** 69,75 **** + (define dynamic:errmsg + "No value defined for this dynamic in the current dynamic environment") + +! (define (dynamic-ref dynamic) + (guarantee-dynamic dynamic) + (let loop ((env *current-dynamic-environment*)) + (cond ((not env) +--- 79,85 ---- + (define dynamic:errmsg + "No value defined for this dynamic in the current dynamic environment") + +! (define-integrable (dynamic-ref dynamic) + (guarantee-dynamic dynamic) + (let loop ((env *current-dynamic-environment*)) + (cond ((not env) +*************** +*** 79,85 **** + (else + (loop (dynamic-environment:parent env)))))) + +! (define (dynamic-set! dynamic obj) + (guarantee-dynamic dynamic) + (let loop ((env *current-dynamic-environment*)) + (cond ((not env) +--- 89,95 ---- + (else + (loop (dynamic-environment:parent env)))))) + +! (define-integrable (dynamic-set! dynamic obj) + (guarantee-dynamic dynamic) + (let loop ((env *current-dynamic-environment*)) + (cond ((not env) +diff -c slib/format.scm nlib/format.scm +*** slib/format.scm Tue Jan 5 14:56:48 1993 +--- nlib/format.scm Tue Feb 9 00:21:09 1993 +*************** +*** 78,84 **** + ; * removed C-style padding support + ; + +! ;;; SCHEME IMPLEMENTATION DEPENDENCIES --------------------------------------- + + ;; To configure the format module for your scheme system, set the variable + ;; format:scheme-system to one of the symbols of (slib elk any). You may add +--- 78,88 ---- + ; * removed C-style padding support + ; + +! ;;; SCHEME IMPLEMENTATION DEPENDENCIES +! ;;; --------------------------------------- +! +! ;;; (minimal) Declarations for CScheme +! (declare (usual-integrations)) + + ;; To configure the format module for your scheme system, set the variable + ;; format:scheme-system to one of the symbols of (slib elk any). You may add +diff -c slib/genwrite.scm nlib/genwrite.scm +*** slib/genwrite.scm Mon Oct 19 14:49:06 1992 +--- nlib/genwrite.scm Tue Feb 9 00:21:10 1993 +*************** +*** 26,31 **** +--- 26,34 ---- + ; + ; where display-string = (lambda (s) (for-each write-char (string->list s)) #t) + ++ ;;; (minimal) Declarations for CScheme ++ (declare (usual-integrations)) ++ + (define (generic-write obj display? width output) + + (define (read-macro? l) +diff -c slib/hash.scm nlib/hash.scm +*** slib/hash.scm Thu Sep 10 00:05:52 1992 +--- nlib/hash.scm Tue Feb 9 00:21:10 1993 +*************** +*** 23,35 **** + ;the equality predicate pred. Pred should be EQ?, EQV?, EQUAL?, =, + ;CHAR=?, CHAR-CI=?, STRING=?, or STRING-CI=?. + +! (define (hash:hash-char char n) + (modulo (char->integer char) n)) + +! (define (hash:hash-char-ci char n) + (modulo (char->integer (char-downcase char)) n)) + +! (define (hash:hash-symbol sym n) + (hash:hash-string (symbol->string sym) n)) + + ;;; I am trying to be careful about overflow and underflow here. +--- 23,40 ---- + ;the equality predicate pred. Pred should be EQ?, EQV?, EQUAL?, =, + ;CHAR=?, CHAR-CI=?, STRING=?, or STRING-CI=?. + +! +! ;;; Declarations for CScheme +! (declare (usual-integrations)) +! (declare (integrate hash)) +! +! (define-integrable (hash:hash-char char n) + (modulo (char->integer char) n)) + +! (define-integrable (hash:hash-char-ci char n) + (modulo (char->integer (char-downcase char)) n)) + +! (define-integrable (hash:hash-symbol sym n) + (hash:hash-string (symbol->string sym) n)) + + ;;; I am trying to be careful about overflow and underflow here. +*************** +*** 173,179 **** + + (define hashq hashv) + +! (define (predicate->hash pred) + (cond ((eq? pred eq?) hashq) + ((eq? pred eqv?) hashv) + ((eq? pred equal?) hash) +--- 178,184 ---- + + (define hashq hashv) + +! (define-integrable (predicate->hash pred) + (cond ((eq? pred eq?) hashq) + ((eq? pred eqv?) hashv) + ((eq? pred equal?) hash) +diff -c slib/hashtab.scm nlib/hashtab.scm +*** slib/hashtab.scm Mon Oct 19 14:49:44 1992 +--- nlib/hashtab.scm Tue Feb 9 00:21:11 1993 +*************** +*** 36,47 **** + ;Returns a procedure of 2 arguments, hashtab and key, which modifies + ;hashtab so that the association whose key is key removed. + + (require 'hash) + (require 'alist) + +! (define (make-hash-table k) (make-vector k '())) + +! (define (predicate->hash-asso pred) + (let ((hashfun (predicate->hash pred)) + (asso (predicate->asso pred))) + (lambda (key hashtab) +--- 36,53 ---- + ;Returns a procedure of 2 arguments, hashtab and key, which modifies + ;hashtab so that the association whose key is key removed. + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ ++ (declare (integrate-external "hash")) ++ (declare (integrate-external "alist")) ++ + (require 'hash) + (require 'alist) + +! (define-integrable (make-hash-table k) (make-vector k '())) + +! (define-integrable (predicate->hash-asso pred) + (let ((hashfun (predicate->hash pred)) + (asso (predicate->asso pred))) + (lambda (key hashtab) +*************** +*** 48,54 **** + (asso key + (vector-ref hashtab (hashfun key (vector-length hashtab))))))) + +! (define (hash-inquirer pred) + (let ((hashfun (predicate->hash pred)) + (ainq (alist-inquirer pred))) + (lambda (hashtab key) +--- 54,60 ---- + (asso key + (vector-ref hashtab (hashfun key (vector-length hashtab))))))) + +! (define-integrable (hash-inquirer pred) + (let ((hashfun (predicate->hash pred)) + (ainq (alist-inquirer pred))) + (lambda (hashtab key) +*************** +*** 55,61 **** + (ainq (vector-ref hashtab (hashfun key (vector-length hashtab))) + key)))) + +! (define (hash-associator pred) + (let ((hashfun (predicate->hash pred)) + (asso (alist-associator pred))) + (lambda (hashtab key val) +--- 61,67 ---- + (ainq (vector-ref hashtab (hashfun key (vector-length hashtab))) + key)))) + +! (define-integrable (hash-associator pred) + (let ((hashfun (predicate->hash pred)) + (asso (alist-associator pred))) + (lambda (hashtab key val) +*************** +*** 64,70 **** + (asso (vector-ref hashtab num) key val))) + hashtab))) + +! (define (hash-remover pred) + (let ((hashfun (predicate->hash pred)) + (arem (alist-remover pred))) + (lambda (hashtab key) +--- 70,76 ---- + (asso (vector-ref hashtab num) key val))) + hashtab))) + +! (define-integrable (hash-remover pred) + (let ((hashfun (predicate->hash pred)) + (arem (alist-remover pred))) + (lambda (hashtab key) +diff -c slib/lineio.scm nlib/lineio.scm +*** slib/lineio.scm Sun Oct 25 01:40:38 1992 +--- nlib/lineio.scm Tue Feb 9 00:21:11 1993 +*************** +*** 28,33 **** +--- 28,36 ---- + ;unspecified value. Port may be ommited, in which case it defaults to + ;the value returned by current-input-port. + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ + (define (read-line . arg) + (let* ((char (apply read-char arg))) + (if (eof-object? char) +*************** +*** 56,61 **** + (+ 1 i) #f)))) + (string-set! str i char))))) + +! (define (write-line str . arg) + (apply display str arg) + (apply newline arg)) +--- 59,64 ---- + (+ 1 i) #f)))) + (string-set! str i char))))) + +! (define-integrable (write-line str . arg) + (apply display str arg) + (apply newline arg)) +diff -c slib/logical.scm nlib/logical.scm +*** slib/logical.scm Mon Feb 1 22:22:04 1993 +--- nlib/logical.scm Tue Feb 9 00:21:11 1993 +*************** +*** 48,53 **** +--- 48,66 ---- + ; + ;;;;------------------------------------------------------------------ + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ (declare (integrate logand ; Exported functions ++ logor ++ logxor ++ lognot ++ ash ++ logcount ++ integer-length ++ bit-extract ++ ipow-by-squaring ++ integer-expt)) ++ + (define logical:integer-expt + (if (provided? 'inexact) + expt +*************** +*** 61,67 **** + (quotient k 2) + (if (even? k) acc (proc acc x)) + proc)))) +- + (define (logical:logand n1 n2) + (cond ((= n1 n2) n1) + ((zero? n1) 0) +--- 74,79 ---- +*************** +*** 90,102 **** + (vector-ref (vector-ref logical:boole-xor (modulo n1 16)) + (modulo n2 16)))))) + +! (define (logical:lognot n) (- -1 n)) + +! (define (logical:bit-extract n start end) + (logical:logand (- (logical:integer-expt 2 (- end start)) 1) + (logical:ash n (- start)))) + +! (define (logical:ash int cnt) + (if (negative? cnt) + (let ((n (logical:integer-expt 2 (- cnt)))) + (if (negative? int) +--- 102,114 ---- + (vector-ref (vector-ref logical:boole-xor (modulo n1 16)) + (modulo n2 16)))))) + +! (define-integrable (logical:lognot n) (- -1 n)) + +! (define-integrable (logical:bit-extract n start end) + (logical:logand (- (logical:integer-expt 2 (- end start)) 1) + (logical:ash n (- start)))) + +! (define-integrable (logical:ash int cnt) + (if (negative? cnt) + (let ((n (logical:integer-expt 2 (- cnt)))) + (if (negative? int) +*************** +*** 104,110 **** + (quotient int n))) + (* (logical:integer-expt 2 cnt) int))) + +! (define (logical:ash-4 x) + (if (negative? x) + (+ -1 (quotient (+ 1 x) 16)) + (quotient x 16))) +--- 116,122 ---- + (quotient int n))) + (* (logical:integer-expt 2 cnt) int))) + +! (define-integrable (logical:ash-4 x) + (if (negative? x) + (+ -1 (quotient (+ 1 x) 16)) + (quotient x 16))) +diff -c slib/mitscheme.init nlib/mitscheme.init +*** slib/mitscheme.init Fri Jan 22 00:52:04 1993 +--- nlib/mitscheme.init Tue Feb 9 00:21:12 1993 +*************** +*** 48,55 **** + + ;;; FORCE-OUTPUT flushes any pending output on optional arg output port + ;;; use this definition if your system doesn't have such a procedure. +! ;(define (force-output . arg) #t) +! (define force-output flush-output) + + ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can + ;;; be returned by CHAR->INTEGER. It is defined by MITScheme. +--- 47,54 ---- + + ;;; FORCE-OUTPUT flushes any pending output on optional arg output port + ;;; use this definition if your system doesn't have such a procedure. +! (define (force-output . arg) #t) +! ;(define force-output flush-output) + + ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can + ;;; be returned by CHAR->INTEGER. It is defined by MITScheme. +diff -c slib/modular.scm nlib/modular.scm +*** slib/modular.scm Sun Feb 2 12:53:26 1992 +--- nlib/modular.scm Tue Feb 9 00:21:13 1993 +*************** +*** 36,41 **** +--- 36,48 ---- + ;Returns (k2 ^ k3) mod k1. + ; + ;;;;-------------------------------------------------------------- ++ ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ ++ (declare (integrate-external "logical")) ++ (declare (integrate modular:negate extended-euclid)) ++ + (require 'logical) + + ;;; from: +*************** +*** 51,57 **** + (caddr res) + (- (cadr res) (* (quotient a b) (caddr res))))))) + +! (define (modular:invert m a) + (let ((d (modular:extended-euclid a m))) + (if (= 1 (car d)) + (modulo (cadr d) m) +--- 58,64 ---- + (caddr res) + (- (cadr res) (* (quotient a b) (caddr res))))))) + +! (define-integrable (modular:invert m a) + (let ((d (modular:extended-euclid a m))) + (if (= 1 (car d)) + (modulo (cadr d) m) +*************** +*** 59,67 **** + + (define modular:negate -) + +! (define (modular:+ m a b) (modulo (+ (- a m) b) m)) + +! (define (modular:- m a b) (modulo (- a b) m)) + + ;;; See: L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package + ;;; with Splitting Facilities." ACM Transactions on Mathematical +--- 66,74 ---- + + (define modular:negate -) + +! (define-integrable (modular:+ m a b) (modulo (+ (- a m) b) m)) + +! (define-integrable (modular:- m a b) (modulo (- a b) m)) + + ;;; See: L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package + ;;; with Splitting Facilities." ACM Transactions on Mathematical +*************** +*** 98,104 **** + (modulo (+ (if (positive? p) (- p m) p) + (* a0 (modulo b q))) m))))) + +! (define (modular:expt m a b) + (cond ((= a 1) 1) + ((= a (- m 1)) (if (odd? b) a 1)) + ((zero? a) 0) +--- 105,111 ---- + (modulo (+ (if (positive? p) (- p m) p) + (* a0 (modulo b q))) m))))) + +! (define-integrable (modular:expt m a b) + (cond ((= a 1) 1) + ((= a (- m 1)) (if (odd? b) a 1)) + ((zero? a) 0) +diff -c slib/obj2str.scm nlib/obj2str.scm +*** slib/obj2str.scm Mon Oct 19 14:49:08 1992 +--- nlib/obj2str.scm Tue Feb 9 00:21:13 1993 +*************** +*** 2,13 **** + + (require 'generic-write) + + ; (object->string obj) returns the textual representation of 'obj' as a + ; string. + ; + ; Note: (write obj) = (display (object->string obj)) + +! (define (object->string obj) + (let ((result '())) + (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t)) + (reverse-string-append result))) +--- 2,17 ---- + + (require 'generic-write) + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ (declare (integrate-external "genwrite")) ++ + ; (object->string obj) returns the textual representation of 'obj' as a + ; string. + ; + ; Note: (write obj) = (display (object->string obj)) + +! (define-integrable (object->string obj) + (let ((result '())) + (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t)) + (reverse-string-append result))) +diff -c slib/pp2str.scm nlib/pp2str.scm +*** slib/pp2str.scm Mon Oct 19 14:49:08 1992 +--- nlib/pp2str.scm Tue Feb 9 00:21:13 1993 +*************** +*** 2,11 **** + + (require 'generic-write) + + ; (pretty-print-to-string obj) returns a string with the pretty-printed + ; textual representation of 'obj'. + +! (define (pp:pretty-print-to-string obj) + (let ((result '())) + (generic-write obj #f 79 (lambda (str) (set! result (cons str result)) #t)) + (reverse-string-append result))) +--- 2,16 ---- + + (require 'generic-write) + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ (declare (integrate-external "genwrite")) ++ (declare (integrate pretty-print-to-string)) ++ + ; (pretty-print-to-string obj) returns a string with the pretty-printed + ; textual representation of 'obj'. + +! (define-integrable (pp:pretty-print-to-string obj) + (let ((result '())) + (generic-write obj #f 79 (lambda (str) (set! result (cons str result)) #t)) + (reverse-string-append result))) +diff -c slib/ppfile.scm nlib/ppfile.scm +*** slib/ppfile.scm Mon Oct 19 14:49:08 1992 +--- nlib/ppfile.scm Tue Feb 9 00:21:14 1993 +*************** +*** 10,15 **** +--- 10,19 ---- + ; + (require 'pretty-print) + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ (declare (integrate-external "pp")) ++ + (define (pprint-file ifile . optarg) + (let ((lst (call-with-input-file ifile + (lambda (iport) +diff -c slib/prime.scm nlib/prime.scm +*** slib/prime.scm Mon Feb 8 20:49:46 1993 +--- nlib/prime.scm Tue Feb 9 00:24:16 1993 +*************** +*** 24,29 **** +--- 24,39 ---- + ;(sort! (factor k) <) + + ;;;;-------------------------------------------------------------- ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ (declare (integrate-external "random")) ++ (declare (integrate-external "modular")) ++ (declare (integrate ++ jacobi-symbol ++ prime? ++ factor)) ++ ++ + (require 'random) + (require 'modular) + +*************** +*** 56,62 **** + ;;; choosing prime:trials=30 should be enough + (define prime:trials 30) + ;;; prime:product is a product of small primes. +! (define prime:product + (let ((p 210)) + (for-each (lambda (s) (set! p (or (string->number s) p))) + '("2310" "30030" "510510" "9699690" "223092870" +--- 66,72 ---- + ;;; choosing prime:trials=30 should be enough + (define prime:trials 30) + ;;; prime:product is a product of small primes. +! (define-integrable prime:product + (let ((p 210)) + (for-each (lambda (s) (set! p (or (string->number s) p))) + '("2310" "30030" "510510" "9699690" "223092870" +*************** +*** 86,92 **** + ; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even + + ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m. +! + ;It may be illuminating to consider the relation of the Lankinen function in + ;a `computational hierarchy' of other factoring functions.* Assumptions are + ;made herein on the basis of conventional digital (binary) computers. Also, +--- 96,102 ---- + ; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even + + ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m. +! + ;It may be illuminating to consider the relation of the Lankinen function in + ;a `computational hierarchy' of other factoring functions.* Assumptions are + ;made herein on the basis of conventional digital (binary) computers. Also, +*************** +*** 94,100 **** + ;be factored is prime). However, all algorithms would probably perform to + ;the same constant multiple of the given orders for complete composite + ;factorizations. +! + ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and + ; O(n*log2(n)) in space. + ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime +--- 104,110 ---- + ;be factored is prime). However, all algorithms would probably perform to + ;the same constant multiple of the given orders for complete composite + ;factorizations. +! + ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and + ; O(n*log2(n)) in space. + ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime +diff -c slib/priorque.scm nlib/priorque.scm +*** slib/priorque.scm Mon Oct 19 14:49:42 1992 +--- nlib/priorque.scm Tue Feb 9 00:21:15 1993 +*************** +*** 22,41 **** + ;;; 1989 MIT Press. + + (require 'record) + (define heap-rtd (make-record-type "heap" '(array size heap?)) + (heap-insert! heap #\A) +diff -c slib/process.scm nlib/process.scm +*** slib/process.scm Wed Nov 4 12:26:50 1992 +--- nlib/process.scm Tue Feb 9 00:21:15 1993 +*************** +*** 21,30 **** + ; + ;;;;---------------------------------------------------------------------- + + (require 'full-continuation) + (require 'queue) + +! (define (add-process! thunk1) + (cond ((procedure? thunk1) + (defer-ints) + (enqueue! process:queue thunk1) +--- 21,33 ---- + ; + ;;;;---------------------------------------------------------------------- + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ + (require 'full-continuation) + (require 'queue) + +! (define-integrable (add-process! thunk1) + (cond ((procedure? thunk1) + (defer-ints) + (enqueue! process:queue thunk1) +*************** +*** 55,63 **** + (define ints-disabled #f) + (define alarm-deferred #f) + +! (define (defer-ints) (set! ints-disabled #t)) + +! (define (allow-ints) + (set! ints-disabled #f) + (cond (alarm-deferred + (set! alarm-deferred #f) +--- 58,66 ---- + (define ints-disabled #f) + (define alarm-deferred #f) + +! (define-integrable (defer-ints) (set! ints-disabled #t)) + +! (define-integrable (allow-ints) + (set! ints-disabled #f) + (cond (alarm-deferred + (set! alarm-deferred #f) +*************** +*** 66,72 **** + ;;; Make THE process queue. + (define process:queue (make-queue)) + +! (define (alarm-interrupt) + (alarm 1) + (if ints-disabled (set! alarm-deferred #t) + (process:schedule!))) +--- 69,75 ---- + ;;; Make THE process queue. + (define process:queue (make-queue)) + +! (define-integrable (alarm-interrupt) + (alarm 1) + (if ints-disabled (set! alarm-deferred #t) + (process:schedule!))) +diff -c slib/randinex.scm nlib/randinex.scm +*** slib/randinex.scm Wed Nov 18 22:59:20 1992 +--- nlib/randinex.scm Tue Feb 9 00:21:16 1993 +*************** +*** 47,52 **** +--- 47,59 ---- + ;For an exponential distribution with mean U use (* U (random:exp)). + ;;;;----------------------------------------------------------------- + ++ ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ (declare (integrate-external "random")) ++ (declare (integrate ++ random:float-radix)) ++ + (define random:float-radix + (+ 1 (exact->inexact random:MASK))) + +*************** +*** 56,61 **** +--- 63,69 ---- + (if (= 1.0 (+ 1 x)) + l + (random:size-float (+ l 1) (/ x random:float-radix)))) ++ + (define random:chunks/float (random:size-float 1 1.0)) + + (define (random:uniform-chunk n state) +*************** +*** 67,73 **** + random:float-radix))) + + ;;; Generate an inexact real between 0 and 1. +! (define (random:uniform state) + (random:uniform-chunk random:chunks/float state)) + + ;;; If x and y are independent standard normal variables, then with +--- 75,81 ---- + random:float-radix))) + + ;;; Generate an inexact real between 0 and 1. +! (define-integrable (random:uniform state) + (random:uniform-chunk random:chunks/float state)) + + ;;; If x and y are independent standard normal variables, then with +*************** +*** 89,95 **** + (do! n (* r (cos t))) + (if (positive? n) (do! (- n 1) (* r (sin t))))))))) + +! (define random:normal + (let ((vect (make-vector 1))) + (lambda args + (apply random:normal-vector! vect args) +--- 97,103 ---- + (do! n (* r (cos t))) + (if (positive? n) (do! (- n 1) (* r (sin t))))))))) + +! (define-integrable random:normal + (let ((vect (make-vector 1))) + (lambda args + (apply random:normal-vector! vect args) +*************** +*** 98,104 **** + ;;; For the uniform distibution on the hollow sphere, pick a normal + ;;; family and scale. + +! (define (random:hollow-sphere! vect . args) + (let ((ms (sqrt (apply random:normal-vector! vect args)))) + (do ((n (- (vector-length vect) 1) (- n 1))) + ((negative? n)) +--- 106,112 ---- + ;;; For the uniform distibution on the hollow sphere, pick a normal + ;;; family and scale. + +! (define-integrable (random:hollow-sphere! vect . args) + (let ((ms (sqrt (apply random:normal-vector! vect args)))) + (do ((n (- (vector-length vect) 1) (- n 1))) + ((negative? n)) +*************** +*** 117,123 **** + ((negative? n)) + (vector-set! vect n (* r (vector-ref vect n)))))) + +! (define (random:exp . args) + (let ((state (if (null? args) *random-state* (car args)))) + (- (log (random:uniform state))))) + +--- 125,131 ---- + ((negative? n)) + (vector-set! vect n (* r (vector-ref vect n)))))) + +! (define-integrable (random:exp . args) + (let ((state (if (null? args) *random-state* (car args)))) + (- (log (random:uniform state))))) + +diff -c slib/random.scm nlib/random.scm +*** slib/random.scm Tue Feb 2 00:02:58 1993 +--- nlib/random.scm Tue Feb 9 00:21:18 1993 +*************** +*** 35,40 **** +--- 35,50 ---- + ;procedures for generating inexact distributions. + ;;;;------------------------------------------------------------------ + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ (declare (integrate-external "logical")) ++ (declare (integrateb ++ random:tap-1 ++ random:size ++ random:chunk-size ++ random:MASK ++ random)) ++ + (require 'logical) + + (define random:tap 24) +*************** +*** 45,50 **** +--- 55,61 ---- + (if (and (exact? trial) (>= most-positive-fixnum trial)) + l + (random:size-int (- l 1))))) ++ + (define random:chunk-size (* 4 (random:size-int 8))) + + (define random:MASK +*************** +*** 107,113 **** + ;;;random:uniform is in randinex.scm. It is needed only if inexact is + ;;;supported. + +! (define (random:make-random-state . args) + (let ((state (if (null? args) *random-state* (car args)))) + (list->vector (vector->list state)))) + +--- 118,124 ---- + ;;;random:uniform is in randinex.scm. It is needed only if inexact is + ;;;supported. + +! (define-integrable (random:make-random-state . args) + (let ((state (if (null? args) *random-state* (car args)))) + (list->vector (vector->list state)))) + +diff -c slib/rbtree.scm nlib/rbtree.scm +*** slib/rbtree.scm Sat Jan 9 13:40:56 1993 +--- nlib/rbtree.scm Tue Feb 9 00:21:18 1993 +*************** +*** 5,11 **** +--- 5,24 ---- + ;;;; PGS, 6 Jul 1990 + ;;; jaffer@ai.mit.edu Ported to SLIB, 1/6/93 + ++ ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ (declare (integrate ++ rb-tree-root ++ set-rb-tree-root! ++ rb-tree-left-rotation-field-maintainer ++ rb-tree-right-rotation-field-maintainer ++ rb-tree-insertion-field-maintainer ++ rb-tree-deletion-field-maintainer ++ rb-tree-prior?)) ++ + (require 'record) ++ + (define rb-tree + (make-record-type + "rb-tree" +*************** +*** 227,233 **** + y) + (set! x y) + (set! y (rb-node-parent y))))) +- + + ;;;; Deletion. We do not entirely follow Cormen, Leiserson and Rivest's lead + ;;;; here, because their use of sentinels is in rather obscenely poor taste. +--- 240,245 ---- +diff -c slib/sort.scm nlib/sort.scm +*** slib/sort.scm Wed Nov 6 00:50:38 1991 +--- nlib/sort.scm Tue Feb 9 00:22:03 1993 +*************** +*** 118,123 **** +--- 118,125 ---- + ; in Scheme. + ;;; -------------------------------------------------------------------- + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ; Honestly, nothing defined here clashes! + + ;;; (sorted? sequence less?) + ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) +diff -c slib/printf.scm nlib/printf.scm +*** slib/printf.scm Mon Oct 19 14:48:58 1992 +--- nlib/printf.scm Tue Feb 9 00:22:03 1993 +*************** +*** 3,8 **** +--- 3,19 ---- + + ;;; Floating point is not handled yet. It should not be hard to do. + ++ ;;; Declarations for CScheme ++ (declare (usual-integrations)) ++ ++ (declare (integrate ++ printf ++ fprintf ++ sprintf ++ stdin ++ stdout ++ stderr)) ++ + (define (stdio:iprintf out format . args) + (let loop ((pos 0) (args args)) + (if (< pos (string-length format)) +*************** +*** 96,105 **** + (else (out (string-ref format pos)) + (loop (+ pos 1) args)))))) + +! (define (stdio:printf format . args) + (apply stdio:iprintf display format args)) + +! (define (stdio:fprintf port format . args) + (if (equal? port (current-output-port)) + (apply stdio:iprintf display format args) + (apply stdio:iprintf (lambda (x) (display x port)) format args))) +--- 107,116 ---- + (else (out (string-ref format pos)) + (loop (+ pos 1) args)))))) + +! (define-integrable (stdio:printf format . args) + (apply stdio:iprintf display format args)) + +! (define-integrable (stdio:fprintf port format . args) + (if (equal? port (current-output-port)) + (apply stdio:iprintf display format args) + (apply stdio:iprintf (lambda (x) (display x port)) format args))) +diff -c slib/strcase.scm nlib/strcase.scm +*** slib/strcase.scm Wed Nov 18 14:15:18 1992 +--- nlib/strcase.scm Tue Feb 9 00:22:03 1993 +*************** +*** 8,27 **** + ;string-upcase!, string-downcase!, string-capitalize! + ; are destructive versions. + +! (define (string-upcase! str) + (do ((i (- (string-length str) 1) (- i 1))) + ((< i 0) str) + (string-set! str i (char-upcase (string-ref str i))))) + +! (define (string-upcase str) + (string-upcase! (string-copy str))) + +! (define (string-downcase! str) + (do ((i (- (string-length str) 1) (- i 1))) + ((< i 0) str) + (string-set! str i (char-downcase (string-ref str i))))) + +! (define (string-downcase str) + (string-downcase! (string-copy str))) + + (define (string-capitalize! str) ; "hello" -> "Hello" +--- 8,30 ---- + ;string-upcase!, string-downcase!, string-capitalize! + ; are destructive versions. + +! ;;; Declarations for CScheme +! (declare (usual-integrations)) +! +! (define-integrable (string-upcase! str) + (do ((i (- (string-length str) 1) (- i 1))) + ((< i 0) str) + (string-set! str i (char-upcase (string-ref str i))))) + +! (define-integrable (string-upcase str) + (string-upcase! (string-copy str))) + +! (define-integrable (string-downcase! str) + (do ((i (- (string-length str) 1) (- i 1))) + ((< i 0) str) + (string-set! str i (char-downcase (string-ref str i))))) + +! (define-integrable (string-downcase str) + (string-downcase! (string-copy str))) + + (define (string-capitalize! str) ; "hello" -> "Hello" +*************** +*** 38,42 **** + (string-set! str i (char-upcase c)))) + (set! non-first-alpha #f)))))) + +! (define (string-capitalize str) + (string-capitalize! (string-copy str))) +--- 41,45 ---- + (string-set! str i (char-upcase c)))) + (set! non-first-alpha #f)))))) + +! (define-integrable (string-capitalize str) + (string-capitalize! (string-copy str))) +diff -c slib/synchk.scm nlib/synchk.scm +*** slib/synchk.scm Mon Jan 27 09:28:48 1992 +--- nlib/synchk.scm Tue Feb 9 00:22:03 1993 +*************** +*** 35,45 **** + ;;; written by Alan Bawden + ;;; modified by Chris Hanson + +! (define (syntax-check pattern form) + (if (not (syntax-match? (cdr pattern) (cdr form))) + (syntax-error "ill-formed special form" form))) + +! (define (ill-formed-syntax form) + (syntax-error "ill-formed special form" form)) + + (define (syntax-match? pattern object) +--- 35,48 ---- + ;;; written by Alan Bawden + ;;; modified by Chris Hanson + +! ;;; Declarations for CScheme +! (declare (usual-integrations)) +! +! (define-integrable (syntax-check pattern form) + (if (not (syntax-match? (cdr pattern) (cdr form))) + (syntax-error "ill-formed special form" form))) + +! (define-integrable (ill-formed-syntax form) + (syntax-error "ill-formed special form" form)) + + (define (syntax-match? pattern object) diff --git a/mitscheme.init b/mitscheme.init new file mode 100644 index 0000000..a6f1c0e --- /dev/null +++ b/mitscheme.init @@ -0,0 +1,254 @@ +;;;"mitscheme.init" Initialization for SLIB for MITScheme -*-scheme-*- +;;; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; Make this part of your ~/.scheme.init file. + +;;; (software-type) should be set to the generic operating system type. +(define (software-type) 'UNIX) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. + +(define (scheme-implementation-type) 'MITScheme) + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "7.3.0") + +;;; *features* should be set to a list of symbols describing features +;;; of this implementation. See Template.scm for the list of feature +;;; names. + +;the following may not be the Right Thing for this application, since +;it causes an error (rather than just returning nil) when the environment +;variable is not defined. +(define getenv get-environment-variable) + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. + +(define (implementation-vicinity) + (case (software-type) + ((UNIX) "/usr/local/src/scheme/") + ((VMS) "scheme$src:"))) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +(define library-vicinity + (let ((library-path + (or (getenv "SCHEME_LIBRARY_PATH") + ;; Use this path if your scheme does not support GETENV. + (case (software-type) + ((UNIX) "/usr/local/lib/slib/") + ((VMS) "lib$scheme:") + ((MS-DOS) "C:\\SLIB\\") + (else ""))))) + (lambda () library-path))) + +(define *features* + '( + source ;can load scheme source files + ;(slib:load-source "filename") + compiled ;can load compiled files + ;(slib:load-compiled "filename") + rev4-report + ieee-p1178 + sicp + rev4-optional-procedures + rev3-procedures + rev2-procedures + multiarg/and- + multiarg-apply + rationalize + object-hash + delay + with-file + string-port + transcript + char-ready? + record + values + dynamic-wind + ieee-floating-point + full-continuation +; sort + queue + pretty-print + object->string + trace ;has macros: TRACE and UNTRACE + compiler + getenv + Xwindows + )) + +;;; (OUTPUT-PORT-WIDTH ) +(define output-port-width output-port/x-size) + +;;; (OUTPUT-PORT-HEIGHT ) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +(define current-error-port + (let ((port console-output-port)) + (lambda () port))) + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam + (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (let ((tmp (string-append "slib_" (number->string cntr)))) + (if (file-exists? tmp) (tmpnam) tmp))))) + +;;; FORCE-OUTPUT flushes any pending output on optional arg output port. +(define force-output flush-output) +;;; MITScheme 7.2 is missing flush-output. Use this instead +;(define (force-output . arg) #t) + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-*PUT-FILE. +(define (call-with-output-string proc) + (let ((co (current-output-port))) + (with-output-to-string + (lambda () + (let ((port (current-output-port))) + (with-output-to-port co + (lambda () (proc port)))))))) + +(define (call-with-input-string string proc) + (let ((ci (current-input-port))) + (with-input-from-string string + (lambda () + (let ((port (current-input-port))) + (with-input-from-port ci + (lambda () (proc port)))))))) + +(define object->string write-to-string) + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. It is defined by MITScheme. + +;;; MOST-POSITIVE-FIXNUM is used in modular.scm +(define most-positive-fixnum #x03FFFFFF) + +;;; Return argument +(define (identity x) x) + +;;; If your implementation provides eval, SLIB:EVAL is single argument +;;; eval using the top-level (user) environment. +;(define (slib:eval form) (eval form (repl/environment (nearest-repl)))) +(define (slib:eval form) (eval form user-initial-environment)) + +(define *macros* '(defmacro)) +(define (defmacro? m) (and (memq m *macros*) #t)) + +(syntax-table-define system-global-syntax-table 'defmacro + (macro defmacargs + (let ((macname (car defmacargs)) (macargs (cadr defmacargs)) + (macbdy (cddr defmacargs))) + `(begin + (set! *macros* (cons ',macname *macros*)) + (syntax-table-define system-global-syntax-table ',macname + (macro ,macargs ,@macbdy)))))) + +(define (macroexpand-1 e) + (if (pair? e) (let ((a (car e))) + (if (and (symbol? a) (defmacro? a)) + (apply (syntax-table-ref system-global-syntax-table a) + (cdr e)) + e)) + e)) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (if (and (symbol? a) (defmacro? a)) + (macroexpand + (apply (syntax-table-ref system-global-syntax-table a) + (cdr e))) + e)) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +(define defmacro:eval slib:eval) +(define defmacro:load load) +;;; If your implementation provides R4RS macros: +;(define macro:eval slib:eval) +;(define macro:load load) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +(define record-modifier record-updater) ;some versions need this? + +;; define an error procedure for the library +(define (slib:error . args) + (apply error-procedure (append args (list (the-environment))))) + +;; define these as appropriate for your system. +(define slib:tab (integer->char 9)) +(define slib:form-feed (integer->char 12)) + +(define in-vicinity string-append) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:exit + (lambda args + (cond ((null? args) (exit)) + ((eqv? #t (car args)) (exit)) + ((and (number? (car args)) (integer? (car args))) (exit (car args))) + (else (exit 1))))) + +;;; Here for backward compatability + +(define (scheme-file-suffix) "") + +;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;; suffix all the module files in SLIB have. See feature 'SOURCE. + +(define slib:load-source load) + +;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;; by compiling "foo.scm" if this implementation can compile files. +;;; See feature 'COMPILED. + +(define slib:load-compiled load) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) + +(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/modular.scm b/modular.scm new file mode 100644 index 0000000..357ce77 --- /dev/null +++ b/modular.scm @@ -0,0 +1,158 @@ +;;;; "modular.scm", modular fixnum arithmetic for Scheme +;;; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define (symmetric:modulus n) + (cond ((or (not (number? n)) (not (positive? n)) (even? n)) + (slib:error 'symmetric:modulus n)) + (else (quotient (+ -1 n) -2)))) + +(define (modulus->integer m) + (cond ((negative? m) (- 1 m m)) + ((zero? m) #f) + (else m))) + +(define (modular:normalize m k) + (cond ((positive? m) (modulo k m)) + ((zero? m) k) + ((<= m k (- m)) k) + ((or (provided? 'bignum) + (<= m (quotient (+ -1 most-positive-fixnum) 2))) + (let* ((pm (+ 1 (* -2 m))) + (s (modulo k pm))) + (if (<= s (- m)) s (- s pm)))) + ((positive? k) (+ (+ (+ k -1) m) m)) + (else (- (- (+ k 1) m) m)))) + +;;;; NOTE: The rest of these functions assume normalized arguments! + +(require 'logical) + +(define (modular:extended-euclid x y) + (define q 0) + (do ((r0 x r1) (r1 y (remainder r0 r1)) + (u0 1 u1) (u1 0 (- u0 (* q u1))) + (v0 0 v1) (v1 1 (- v0 (* q v1)))) + ;; (assert (= r0 (+ (* u0 x) (* v0 y)))) + ;; (assert (= r1 (+ (* u1 x) (* v1 y)))) + ((zero? r1) (list r0 u0 v0)) + (set! q (quotient r0 r1)))) + +(define (modular:invertable? m a) + (eqv? 1 (gcd (or (modulus->integer m) 0) a))) + +(define (modular:invert m a) + (cond ((eqv? 1 (abs a)) a) ; unit + (else + (let ((pm (modulus->integer m))) + (cond + (pm + (let ((d (modular:extended-euclid (modular:normalize pm a) pm))) + (if (= 1 (car d)) + (modular:normalize m (cadr d)) + (slib:error 'modular:invert "can't invert" m a)))) + (else (slib:error 'modular:invert "can't invert" m a))))))) + +(define (modular:negate m a) + (if (zero? a) 0 + (if (negative? m) (- a) + (- m a)))) + +;;; Being careful about overflow here +(define (modular:+ m a b) + (cond ((positive? m) + (modulo (+ (- a m) b) m)) + ((zero? m) (+ a b)) + ((negative? a) + (if (negative? b) + (let ((s (+ (- a m) b))) + (if (negative? s) + (- s -1 m) + (+ s m))) + (+ a b))) + ((negative? b) (+ a b)) + (else (let ((s (+ (+ a m) b))) + (if (positive? s) + (+ s -1 m) + (- s m)))))) + +(define (modular:- m a b) + (cond ((positive? m) (modulo (- a b) m)) + ((zero? m) (- a b)) + (else (modular:+ m a (- b))))) + +;;; See: L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +;;; with Splitting Facilities." ACM Transactions on Mathematical +;;; Software, 17:98-111 (1991) + +;;; modular:r = 2**((nb-2)/2) where nb = number of bits in a word. +(define modular:r + (ash 1 (quotient (integer-length most-positive-fixnum) 2))) +(define modular:* + (if (provided? 'bignum) + (lambda (m a b) + (cond ((zero? m) (* a b)) + ((positive? m) (modulo (* a b) m)) + (else (modular:normalize m (* a b))))) + (lambda (m a b) + (let ((a0 a) + (p 0)) + (cond + ((zero? m) (* a b)) + ((negative? m) + "This doesn't work for the full range of modulus M;" + "Someone please create or convert the following" + "algorighm to work with symmetric representation" + (modular:normalize m (* a b))) + (else + (cond + ((< a modular:r)) + ((< b modular:r) (set! a b) (set! b a0) (set! a0 a)) + (else + (set! a0 (modulo a modular:r)) + (let ((a1 (quotient a modular:r)) + (qh (quotient m modular:r)) + (rh (modulo m modular:r))) + (cond ((>= a1 modular:r) + (set! a1 (- a1 modular:r)) + (set! p (modulo (- (* modular:r (modulo b qh)) + (* (quotient b qh) rh)) m)))) + (cond ((not (zero? a1)) + (let ((q (quotient m a1))) + (set! p (- p (* (quotient b q) (modulo m a1)))) + (set! p (modulo (+ (if (positive? p) (- p m) p) + (* a1 (modulo b q))) m))))) + (set! p (modulo (- (* modular:r (modulo p qh)) + (* (quotient p qh) rh)) m))))) + (if (zero? a0) + p + (let ((q (quotient m a0))) + (set! p (- p (* (quotient b q) (modulo m a0)))) + (modulo (+ (if (positive? p) (- p m) p) + (* a0 (modulo b q))) m))))))))) + +(define (modular:expt m a b) + (cond ((= a 1) 1) + ((= a (- m 1)) (if (odd? b) a 1)) + ((zero? a) 0) + ((zero? m) (integer-expt a b)) + (else + (logical:ipow-by-squaring a b 1 + (lambda (c d) (modular:* m c d)))))) + +(define extended-euclid modular:extended-euclid) diff --git a/mulapply.scm b/mulapply.scm new file mode 100644 index 0000000..d696ee2 --- /dev/null +++ b/mulapply.scm @@ -0,0 +1,28 @@ +; "mulapply.scm" Redefine APPLY take more than 2 arguments. +;Copyright (C) 1991 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define two-arg:apply apply) +(define apply + (lambda args + (two-arg:apply (car args) (apply:append-to-last (cdr args))))) + +(define (apply:append-to-last lst) + (if (null? (cdr lst)) + (car lst) + (cons (car lst) (apply:append-to-last (cdr lst))))) diff --git a/mularg.scm b/mularg.scm new file mode 100644 index 0000000..3d62cf4 --- /dev/null +++ b/mularg.scm @@ -0,0 +1,10 @@ +;;; "mularg.scm" Redefine - and / to take more than 2 arguments. + +(let ((maker + (lambda (op) + (lambda (d1 . ds) + (cond ((null? ds) (op d1)) + ((null? (cdr ds)) (op d1 (car ds))) + (else (for-each (lambda (d) (set! d1 (op d1 d))) ds) d1)))))) + (set! / (maker /)) + (set! - (maker -))) diff --git a/mwdenote.scm b/mwdenote.scm new file mode 100644 index 0000000..c3fe5f3 --- /dev/null +++ b/mwdenote.scm @@ -0,0 +1,273 @@ +;"mwdenote.scm" Syntactic Environments +; Copyright 1992 William Clinger +; +; Permission to copy this software, in whole or in part, to use this +; software for any lawful purpose, and to redistribute this software +; is granted subject to the restriction that all copies made of this +; software must include this copyright notice in full. +; +; I also request that you send me a copy of any improvements that you +; make to this software so that they may be incorporated within it to +; the benefit of the Scheme community. + +;;;; Syntactic environments. + +; A syntactic environment maps identifiers to denotations, +; where a denotation is one of +; +; (special ) +; (macro ) +; (identifier ) +; +; and where is one of +; +; quote +; lambda +; if +; set! +; begin +; define +; define-syntax +; let-syntax +; letrec-syntax +; syntax-rules +; +; and where is a compiled (see R4RS), +; is a syntactic environment, and is an identifier. + +(define mw:standard-syntax-environment + '((quote . (special quote)) + (lambda . (special lambda)) + (if . (special if)) + (set! . (special set!)) + (begin . (special begin)) + (define . (special define)) + (let . (special let)) ;; @@ added KAD + (let* . (special let*)) ;; @@ " + (letrec . (special letrec)) ;; @@ " + (quasiquote . (special quasiquote)) ;; @@ " + (unquote . (special unquote)) ;; @@ " + (unquote-splicing . (special unquote-splicing)) ; @@ " + (do . (special do)) ;; @@ " + (define-syntax . (special define-syntax)) + (let-syntax . (special let-syntax)) + (letrec-syntax . (special letrec-syntax)) + (syntax-rules . (special syntax-rules)) + (... . (identifier ...)) + (::: . (identifier :::)))) + +; An unforgeable synonym for lambda, used to expand definitions. + +(define mw:lambda0 (string->symbol " lambda ")) + +; The mw:global-syntax-environment will always be a nonempty +; association list since there is no way to remove the entry +; for mw:lambda0. That entry is used as a header by destructive +; operations. + +(define mw:global-syntax-environment + (cons (cons mw:lambda0 + (cdr (assq 'lambda mw:standard-syntax-environment))) + (mw:syntax-copy mw:standard-syntax-environment))) + +(define (mw:global-syntax-environment-set! env) + (set-cdr! mw:global-syntax-environment env)) + +(define (mw:syntax-bind-globally! id denotation) + (if (and (mw:identifier? denotation) + (eq? id (mw:identifier-name denotation))) + (letrec ((remove-bindings-for-id + (lambda (bindings) + (cond ((null? bindings) '()) + ((eq? (caar bindings) id) + (remove-bindings-for-id (cdr bindings))) + (else (cons (car bindings) + (remove-bindings-for-id (cdr bindings)))))))) + (mw:global-syntax-environment-set! + (remove-bindings-for-id (cdr mw:global-syntax-environment)))) + (let ((x (assq id mw:global-syntax-environment))) + (if x + (set-cdr! x denotation) + (mw:global-syntax-environment-set! + (cons (cons id denotation) + (cdr mw:global-syntax-environment))))))) + +(define (mw:syntax-divert env1 env2) + (append env2 env1)) + +(define (mw:syntax-extend env ids denotations) + (mw:syntax-divert env (map cons ids denotations))) + +(define (mw:syntax-lookup-raw env id) + (let ((entry (assq id env))) + (if entry + (cdr entry) + #f))) + +(define (mw:syntax-lookup env id) + (or (mw:syntax-lookup-raw env id) + (mw:make-identifier-denotation id))) + +(define (mw:syntax-assign! env id denotation) + (let ((entry (assq id env))) + (if entry + (set-cdr! entry denotation) + (mw:bug "Bug detected in mw:syntax-assign!" env id denotation)))) + +(define mw:denote-of-quote + (mw:syntax-lookup mw:standard-syntax-environment 'quote)) + +(define mw:denote-of-lambda + (mw:syntax-lookup mw:standard-syntax-environment 'lambda)) + +(define mw:denote-of-if + (mw:syntax-lookup mw:standard-syntax-environment 'if)) + +(define mw:denote-of-set! + (mw:syntax-lookup mw:standard-syntax-environment 'set!)) + +(define mw:denote-of-begin + (mw:syntax-lookup mw:standard-syntax-environment 'begin)) + +(define mw:denote-of-define + (mw:syntax-lookup mw:standard-syntax-environment 'define)) + +(define mw:denote-of-define-syntax + (mw:syntax-lookup mw:standard-syntax-environment 'define-syntax)) + +(define mw:denote-of-let-syntax + (mw:syntax-lookup mw:standard-syntax-environment 'let-syntax)) + +(define mw:denote-of-letrec-syntax + (mw:syntax-lookup mw:standard-syntax-environment 'letrec-syntax)) + +(define mw:denote-of-syntax-rules + (mw:syntax-lookup mw:standard-syntax-environment 'syntax-rules)) + +(define mw:denote-of-... + (mw:syntax-lookup mw:standard-syntax-environment '...)) + +(define mw:denote-of-::: + (mw:syntax-lookup mw:standard-syntax-environment ':::)) + +(define mw:denote-of-let + (mw:syntax-lookup mw:standard-syntax-environment 'let)) ;; @@ KenD + +(define mw:denote-of-let* + (mw:syntax-lookup mw:standard-syntax-environment 'let*)) ;; @@ KenD + +(define mw:denote-of-letrec + (mw:syntax-lookup mw:standard-syntax-environment 'letrec)) ;; @@ KenD + +(define mw:denote-of-quasiquote + (mw:syntax-lookup mw:standard-syntax-environment 'quasiquote)) ;; @@ KenD + +(define mw:denote-of-unquote + (mw:syntax-lookup mw:standard-syntax-environment 'unquote)) ;; @@ KenD + +(define mw:denote-of-unquote-splicing + (mw:syntax-lookup mw:standard-syntax-environment 'unquote-splicing)) ;@@ KenD + +(define mw:denote-of-do + (mw:syntax-lookup mw:standard-syntax-environment 'do)) ;; @@ KenD + +(define mw:denote-class car) + +;(define (mw:special? denotation) +; (eq? (mw:denote-class denotation) 'special)) + +;(define (mw:macro? denotation) +; (eq? (mw:denote-class denotation) 'macro)) + +(define (mw:identifier? denotation) + (eq? (mw:denote-class denotation) 'identifier)) + +(define (mw:make-identifier-denotation id) + (list 'identifier id)) + +(define macwork:rules cadr) +(define macwork:env caddr) +(define mw:identifier-name cadr) + +(define (mw:same-denotation? d1 d2) + (or (eq? d1 d2) + (and (mw:identifier? d1) + (mw:identifier? d2) + (eq? (mw:identifier-name d1) + (mw:identifier-name d2))))) + +; Renaming of variables. + +; Given a datum, strips the suffixes from any symbols that appear within +; the datum, trying not to copy any more of the datum than necessary. +; Well, right now I'm just copying the datum, but I need to fix that! + +(define (mw:strip x) + (cond ((symbol? x) + (let ((chars (memv mw:suffix-character + (reverse (string->list + (symbol->string x)))))) + (if chars + (string->symbol + (list->string (reverse (cdr chars)))) + x))) + ((pair? x) + (cons (mw:strip (car x)) + (mw:strip (cdr x)))) + ((vector? x) + (list->vector (map mw:strip (vector->list x)))) + (else x))) + +; Given a list of identifiers, returns an alist that associates each +; identifier with a fresh identifier. + +(define (mw:rename-vars vars) + (set! mw:renaming-counter (+ mw:renaming-counter 1)) + (let ((suffix (string-append (string mw:suffix-character) + (number->string mw:renaming-counter)))) + (map (lambda (var) + (if (symbol? var) + (cons var + (string->symbol + (string-append (symbol->string var) suffix))) + (slib:error "Illegal variable" var))) + vars))) + +; Given a syntactic environment env to be extended, an alist returned +; by mw:rename-vars, and a syntactic environment env2, extends env by +; binding the fresh identifiers to the denotations of the original +; identifiers in env2. + +(define (mw:syntax-alias env alist env2) + (mw:syntax-divert + env + (map (lambda (name-pair) + (let ((old-name (car name-pair)) + (new-name (cdr name-pair))) + (cons new-name + (mw:syntax-lookup env2 old-name)))) + alist))) + +; Given a syntactic environment and an alist returned by mw:rename-vars, +; extends the environment by binding the old identifiers to the fresh +; identifiers. + +(define (mw:syntax-rename env alist) + (mw:syntax-divert env + (map (lambda (old new) + (cons old (mw:make-identifier-denotation new))) + (map car alist) + (map cdr alist)))) + +; Given a and an alist returned by mw:rename-vars that contains +; a new name for each formal identifier in , renames the +; formal identifiers. + +(define (mw:rename-formals formals alist) + (cond ((null? formals) '()) + ((pair? formals) + (cons (cdr (assq (car formals) alist)) + (mw:rename-formals (cdr formals) alist))) + (else (cdr (assq formals alist))))) + +(define mw:renaming-counter 0) diff --git a/mwexpand.scm b/mwexpand.scm new file mode 100644 index 0000000..10083a3 --- /dev/null +++ b/mwexpand.scm @@ -0,0 +1,548 @@ +;"mwexpand.scm" macro expander +; Copyright 1992 William Clinger +; +; Permission to copy this software, in whole or in part, to use this +; software for any lawful purpose, and to redistribute this software +; is granted subject to the restriction that all copies made of this +; software must include this copyright notice in full. +; +; I also request that you send me a copy of any improvements that you +; make to this software so that they may be incorporated within it to +; the benefit of the Scheme community. + +; The external entry points and kernel of the macro expander. +; +; Part of this code is snarfed from the Twobit macro expander. + +(define mw:define-syntax-scope + (let ((flag 'letrec)) + (lambda args + (cond ((null? args) flag) + ((not (null? (cdr args))) + (apply mw:warn + "Too many arguments passed to define-syntax-scope" + args)) + ((memq (car args) '(letrec letrec* let*)) + (set! flag (car args))) + (else (mw:warn "Unrecognized argument to define-syntax-scope" + (car args))))))) + +(define mw:quit ; assigned by macwork:expand + (lambda (v) v)) + +(define (macwork:expand def-or-exp) + (call-with-current-continuation + (lambda (k) + (set! mw:quit k) + (set! mw:renaming-counter 0) + (mw:desugar-definitions def-or-exp mw:global-syntax-environment)))) + +(define (mw:desugar-definitions exp env) + (letrec + ((define-loop + (lambda (exp rest first) + (cond ((and (pair? exp) + (eq? (mw:syntax-lookup env (car exp)) + mw:denote-of-begin) + (pair? (cdr exp))) + (define-loop (cadr exp) (append (cddr exp) rest) first)) + ((and (pair? exp) + (eq? (mw:syntax-lookup env (car exp)) + mw:denote-of-define)) + (let ((exp (desugar-define exp env))) + (cond ((and (null? first) (null? rest)) + exp) + ((null? rest) + (cons mw:begin1 (reverse (cons exp first)))) + (else (define-loop (car rest) + (cdr rest) + (cons exp first)))))) + ((and (pair? exp) + (eq? (mw:syntax-lookup env (car exp)) + mw:denote-of-define-syntax) + (null? first)) + (define-syntax-loop exp rest)) + ((and (null? first) (null? rest)) + (mw:expand exp env)) + ((null? rest) + (cons mw:begin1 (reverse (cons (mw:expand exp env) first)))) + (else (cons mw:begin1 + (append (reverse first) + (map (lambda (exp) (mw:expand exp env)) + (cons exp rest)))))))) + + (desugar-define + (lambda (exp env) + (cond + ((null? (cdr exp)) (mw:error "Malformed definition" exp)) + ; (define foo) syntax is transformed into (define foo (undefined)). + ((null? (cddr exp)) + (let ((id (cadr exp))) + (redefinition id) + (mw:syntax-bind-globally! id (mw:make-identifier-denotation id)) + (list mw:define1 id mw:undefined))) + ((pair? (cadr exp)) + ; mw:lambda0 is an unforgeable lambda, needed here because the + ; lambda expression will undergo further expansion. + (desugar-define `(,mw:define1 ,(car (cadr exp)) + (,mw:lambda0 ,(cdr (cadr exp)) + ,@(cddr exp))) + env)) + ((> (length exp) 3) (mw:error "Malformed definition" exp)) + (else (let ((id (cadr exp))) + (redefinition id) + (mw:syntax-bind-globally! id (mw:make-identifier-denotation id)) + `(,mw:define1 ,id ,(mw:expand (caddr exp) env))))))) + + (define-syntax-loop + (lambda (exp rest) + (cond ((and (pair? exp) + (eq? (mw:syntax-lookup env (car exp)) + mw:denote-of-begin) + (pair? (cdr exp))) + (define-syntax-loop (cadr exp) (append (cddr exp) rest))) + ((and (pair? exp) + (eq? (mw:syntax-lookup env (car exp)) + mw:denote-of-define-syntax)) + (if (pair? (cdr exp)) + (redefinition (cadr exp))) + (if (null? rest) + (mw:define-syntax exp env) + (begin (mw:define-syntax exp env) + (define-syntax-loop (car rest) (cdr rest))))) + ((null? rest) + (mw:expand exp env)) + (else (cons mw:begin1 + (map (lambda (exp) (mw:expand exp env)) + (cons exp rest))))))) + + (redefinition + (lambda (id) + (if (symbol? id) + (if (not (mw:identifier? + (mw:syntax-lookup mw:global-syntax-environment id))) + (mw:warn "Redefining keyword" id)) + (mw:error "Malformed variable or keyword" id))))) + + ; body of letrec + + (define-loop exp '() '()))) + +; Given an expression and a syntactic environment, +; returns an expression in core Scheme. + +(define (mw:expand exp env) + (if (not (pair? exp)) + (mw:atom exp env) + (let ((keyword (mw:syntax-lookup env (car exp)))) + (case (mw:denote-class keyword) + ((special) + (cond + ((eq? keyword mw:denote-of-quote) (mw:quote exp)) + ((eq? keyword mw:denote-of-lambda) (mw:lambda exp env)) + ((eq? keyword mw:denote-of-if) (mw:if exp env)) + ((eq? keyword mw:denote-of-set!) (mw:set exp env)) + ((eq? keyword mw:denote-of-begin) (mw:begin exp env)) + ((eq? keyword mw:denote-of-let-syntax) (mw:let-syntax exp env)) + ((eq? keyword mw:denote-of-letrec-syntax) + (mw:letrec-syntax exp env)) + ; @@ let, let*, letrec, paint within quasiquotation -- kend + ((eq? keyword mw:denote-of-let) (mw:let exp env)) + ((eq? keyword mw:denote-of-let*) (mw:let* exp env)) + ((eq? keyword mw:denote-of-letrec) (mw:letrec exp env)) + ((eq? keyword mw:denote-of-quasiquote) (mw:quasiquote exp env)) + ((eq? keyword mw:denote-of-do) (mw:do exp env)) + ((or (eq? keyword mw:denote-of-define) + (eq? keyword mw:denote-of-define-syntax)) + ;; slight hack to allow expansion into defines -KenD + (if mw:in-define? + (mw:error "Definition out of context" exp) + (begin + (set! mw:in-define? #t) + (let ( (result (mw:desugar-definitions exp env)) ) + (set! mw:in-define? #f) + result)) + )) + (else (mw:bug "Bug detected in mw:expand" exp env)))) + ((macro) (mw:macro exp env)) + ((identifier) (mw:application exp env)) + (else (mw:bug "Bug detected in mw:expand" exp env)) + ) ) +) ) + +(define mw:in-define? #f) ; should be fluid + +(define (mw:atom exp env) + (cond ((not (symbol? exp)) + ; Here exp ought to be a boolean, number, character, or string, + ; but I'll allow for non-standard extensions by passing exp + ; to the underlying Scheme system without further checking. + exp) + (else (let ((denotation (mw:syntax-lookup env exp))) + (case (mw:denote-class denotation) + ((special macro) + (mw:error "Syntactic keyword used as a variable" exp env)) + ((identifier) (mw:identifier-name denotation)) + (else (mw:bug "Bug detected by mw:atom" exp env))))))) + +(define (mw:quote exp) + (if (= (mw:safe-length exp) 2) + (list mw:quote1 (mw:strip (cadr exp))) + (mw:error "Malformed quoted constant" exp))) + +(define (mw:lambda exp env) + (if (> (mw:safe-length exp) 2) + (let* ((formals (cadr exp)) + (alist (mw:rename-vars (mw:make-null-terminated formals))) + (env (mw:syntax-rename env alist)) + (body (cddr exp))) + (list mw:lambda1 + (mw:rename-formals formals alist) + (mw:body body env))) + (mw:error "Malformed lambda expression" exp))) + +(define (mw:body body env) + (define (loop body env defs) + (if (null? body) + (mw:error "Empty body")) + (let ((exp (car body))) + (if (and (pair? exp) + (symbol? (car exp))) + (let ((denotation (mw:syntax-lookup env (car exp)))) + (case (mw:denote-class denotation) + ((special) + (cond ((eq? denotation mw:denote-of-begin) + (loop (append (cdr exp) (cdr body)) env defs)) + ((eq? denotation mw:denote-of-define) + (loop (cdr body) env (cons exp defs))) + (else (mw:finalize-body body env defs)))) + ((macro) + (mw:transcribe exp + env + (lambda (exp env) + (loop (cons exp (cdr body)) + env + defs)))) + ((identifier) + (mw:finalize-body body env defs)) + (else (mw:bug "Bug detected in mw:body" body env)))) + (mw:finalize-body body env defs)))) + (loop body env '())) + +(define (mw:finalize-body body env defs) + (if (null? defs) + (let ((body (map (lambda (exp) (mw:expand exp env)) + body))) + (if (null? (cdr body)) + (car body) + (cons mw:begin1 body))) + (let* ((alist (mw:rename-vars '(quote lambda set!))) + (env (mw:syntax-alias env alist mw:standard-syntax-environment)) + (new-quote (cdr (assq 'quote alist))) + (new-lambda (cdr (assq 'lambda alist))) + (new-set! (cdr (assq 'set! alist)))) + (define (desugar-definition def) + (if (> (mw:safe-length def) 2) + (cond ((pair? (cadr def)) + (desugar-definition + `(,(car def) + ,(car (cadr def)) + (,new-lambda + ,(cdr (cadr def)) + ,@(cddr def))))) + ((= (length def) 3) + (cdr def)) + (else (mw:error "Malformed definition" def env))) + (mw:error "Malformed definition" def env))) + (mw:letrec + `(letrec ,(map desugar-definition (reverse defs)) ,@body) + env))) + ) + +(define (mw:if exp env) + (let ((n (mw:safe-length exp))) + (if (or (= n 3) (= n 4)) + (cons mw:if1 (map (lambda (exp) (mw:expand exp env)) (cdr exp))) + (mw:error "Malformed if expression" exp env)))) + +(define (mw:set exp env) + (if (= (mw:safe-length exp) 3) + `(,mw:set!1 ,(mw:expand (cadr exp) env) ,(mw:expand (caddr exp) env)) + (mw:error "Malformed assignment" exp env))) + +(define (mw:begin exp env) + (if (positive? (mw:safe-length exp)) + `(,mw:begin1 ,@(map (lambda (exp) (mw:expand exp env)) (cdr exp))) + (mw:error "Malformed begin expression" exp env))) + +(define (mw:application exp env) + (if (> (mw:safe-length exp) 0) + (map (lambda (exp) (mw:expand exp env)) + exp) + (mw:error "Malformed application"))) + +; I think the environment argument should always be global here. + +(define (mw:define-syntax exp env) + (cond ((and (= (mw:safe-length exp) 3) + (symbol? (cadr exp))) + (mw:define-syntax1 (cadr exp) + (caddr exp) + env + (mw:define-syntax-scope))) + ((and (= (mw:safe-length exp) 4) + (symbol? (cadr exp)) + (memq (caddr exp) '(letrec letrec* let*))) + (mw:define-syntax1 (cadr exp) + (cadddr exp) + env + (caddr exp))) + (else (mw:error "Malformed define-syntax" exp env)))) + +(define (mw:define-syntax1 keyword spec env scope) + (case scope + ((letrec) (mw:define-syntax-letrec keyword spec env)) + ((letrec*) (mw:define-syntax-letrec* keyword spec env)) + ((let*) (mw:define-syntax-let* keyword spec env)) + (else (mw:bug "Weird scope" scope))) + (list mw:quote1 keyword)) + +(define (mw:define-syntax-letrec keyword spec env) + (mw:syntax-bind-globally! + keyword + (mw:compile-transformer-spec spec env))) + +(define (mw:define-syntax-letrec* keyword spec env) + (let* ((env (mw:syntax-extend (mw:syntax-copy env) + (list keyword) + '((fake denotation)))) + (transformer (mw:compile-transformer-spec spec env))) + (mw:syntax-assign! env keyword transformer) + (mw:syntax-bind-globally! keyword transformer))) + +(define (mw:define-syntax-let* keyword spec env) + (mw:syntax-bind-globally! + keyword + (mw:compile-transformer-spec spec (mw:syntax-copy env)))) + +(define (mw:let-syntax exp env) + (if (and (> (mw:safe-length exp) 2) + (comlist:every (lambda (binding) + (and (pair? binding) + (symbol? (car binding)) + (pair? (cdr binding)) + (null? (cddr binding)))) + (cadr exp))) + (mw:body (cddr exp) + (mw:syntax-extend env + (map car (cadr exp)) + (map (lambda (spec) + (mw:compile-transformer-spec + spec + env)) + (map cadr (cadr exp))))) + (mw:error "Malformed let-syntax" exp env))) + +(define (mw:letrec-syntax exp env) + (if (and (> (mw:safe-length exp) 2) + (comlist:every (lambda (binding) + (and (pair? binding) + (symbol? (car binding)) + (pair? (cdr binding)) + (null? (cddr binding)))) + (cadr exp))) + (let ((env (mw:syntax-extend env + (map car (cadr exp)) + (map (lambda (id) + '(fake denotation)) + (cadr exp))))) + (for-each (lambda (id spec) + (mw:syntax-assign! + env + id + (mw:compile-transformer-spec spec env))) + (map car (cadr exp)) + (map cadr (cadr exp))) + (mw:body (cddr exp) env)) + (mw:error "Malformed let-syntax" exp env))) + +(define (mw:macro exp env) + (mw:transcribe exp + env + (lambda (exp env) + (mw:expand exp env)))) + +; To do: +; Clean up alist hacking et cetera. + +;;----------------------------------------------------------------- +;; The following was added to allow expansion without flattening +;; LETs to LAMBDAs so that the origianl structure of the program +;; is preserved by macro expansion. I.e. so that usual.scm is not +;; required. -- added KenD + +(define (mw:process-let-bindings alist binding-list env) ;; helper proc + (map (lambda (bind) + (list (cdr (assq (car bind) alist)) ; renamed name + (mw:body (cdr bind) env))) ; alpha renamed value expression + binding-list) +) + +(define (mw:strip-begin exp) ;; helper proc: mw:body sometimes puts one in + (if (and (pair? exp) (eq? (car exp) 'begin)) + (cdr exp) + exp) +) + +; LET +(define (mw:let exp env) + (let* ( (name (if (or (pair? (cadr exp)) (null? (cadr exp))) + #f + (cadr exp))) ; named let? + (binds (if name (caddr exp) (cadr exp))) + (body (if name (cdddr exp) (cddr exp))) + (vars (if (null? binds) #f (map car binds))) + (alist (if vars (mw:rename-vars vars) #f)) + (newenv (if alist (mw:syntax-rename env alist) env)) + ) + (if name ;; extend env with new name + (let ( (rename (mw:rename-vars (list name))) ) + (set! alist (append rename alist)) + (set! newenv (mw:syntax-rename newenv rename)) + ) ) + `(let + ,@(if name (list (cdr (assq name alist))) '()) + ,(mw:process-let-bindings alist binds env) + ,(mw:body body newenv)) +) ) + + +; LETREC differs from LET in that the binding values are processed in the +; new rather than the original environment. + +(define (mw:letrec exp env) + (let* ( (binds (cadr exp)) + (body (cddr exp)) + (vars (if (null? binds) #f (map car binds))) + (alist (if vars (mw:rename-vars vars) #f)) + (newenv (if alist (mw:syntax-rename env alist) env)) + ) + `(letrec + ,(mw:process-let-bindings alist binds newenv) + ,(mw:body body newenv)) +) ) + + +; LET* adds to ENV for each new binding. + +(define (mw:let* exp env) + (let ( (binds (cadr exp)) + (body (cddr exp)) + ) + (let bind-loop ( (bindings binds) (newbinds '()) (newenv env) ) + (if (null? bindings) + `(let* ,(reverse newbinds) ,(mw:body body newenv)) + (let* ( (bind (car bindings)) + (var (car bind)) + (valexp (cdr bind)) + (rename (mw:rename-vars (list var))) + (next-newenv (mw:syntax-rename newenv rename)) + ) + (bind-loop (cdr bindings) + (cons (list (cdr (assq var rename)) + (mw:body valexp newenv)) + newbinds) + next-newenv)) +) ) ) ) + + +; DO + +(define (mw:process-do-bindings var-init-steps alist oldenv newenv) ;; helper proc + (map (lambda (vis) + (let ( (v (car vis)) + (i (cadr vis)) + (s (if (null? (cddr vis)) (car vis) (caddr vis)))) + `( ,(cdr (assq v alist)) ; renamed name + ,(mw:body (list i) oldenv) ; init in outer/old env + ,(mw:body (list s) newenv) ))) ; step in letrec/inner/new env + var-init-steps) +) + +(define (mw:do exp env) + (let* ( (vis (cadr exp)) ; (Var Init Step ...) + (ts (caddr exp)) ; (Test Sequence ...) + (com (cdddr exp)) ; (COMmand ...) + (vars (if (null? vis) #f (map car vis))) + (rename (if vars (mw:rename-vars vars) #f)) + (newenv (if vars (mw:syntax-rename env rename) env)) + ) + `(do ,(if vars (mw:process-do-bindings vis rename env newenv) '()) + ,(if (null? ts) '() (mw:strip-begin (mw:body (list ts) newenv))) + ,@(if (null? com) '() (list (mw:body com newenv)))) +) ) + +; +; Quasiquotation (backquote) +; +; At level 0, unquoted forms are left painted (not mw:strip'ed). +; At higher levels, forms which are unquoted to level 0 are painted. +; This includes forms within quotes. E.g.: +; (lambda (a) +; (quasiquote +; (a (unquote a) b (quasiquote (a (unquote (unquote a)) b))))) +;or equivalently: +; (lambda (a) `(a ,a b `(a ,,a b))) +;=> +; (lambda (a|1) `(a ,a|1 b `(a ,,a|1 b))) + +(define (mw:quasiquote exp env) + + (define (mw:atom exp env) + (if (not (symbol? exp)) + exp + (let ((denotation (mw:syntax-lookup env exp))) + (case (mw:denote-class denotation) + ((special macro identifier) (mw:identifier-name denotation)) + (else (mw:bug "Bug detected by mw:atom" exp env)))) + ) ) + + (define (quasi subexp level) + (cond + ((null? subexp) subexp) + ((not (or (pair? subexp) (vector? subexp))) + (if (zero? level) (mw:atom subexp env) subexp) ; the work is here + ) + ((vector? subexp) + (let* ((l (vector-length subexp)) + (v (make-vector l))) + (do ((i 0 (+ i 1))) + ((= i l) v) + (vector-set! v i (quasi (vector-ref subexp i) level)) + ) + ) + ) + (else + (let ( (keyword (mw:syntax-lookup env (car subexp))) ) + (cond + ((eq? keyword mw:denote-of-unquote) + (cons 'unquote (quasi (cdr subexp) (- level 1))) + ) + ((eq? keyword mw:denote-of-unquote-splicing) + (cons 'unquote-splicing (quasi (cdr subexp) (- level 1))) + ) + ((eq? keyword mw:denote-of-quasiquote) + (cons 'quasiquote (quasi (cdr subexp) (+ level 1))) + ) + (else + (cons (quasi (car subexp) level) (quasi (cdr subexp) level)) + ) + ) + ) ) ; end else, let + ) ; end cond + ) + + (quasi exp 0) ; need to unquote to level 0 to paint +) + +;; --- E O F --- diff --git a/mwsynrul.scm b/mwsynrul.scm new file mode 100644 index 0000000..1784441 --- /dev/null +++ b/mwsynrul.scm @@ -0,0 +1,343 @@ +; "mwsynrul.scm" Compiler for a . +; Copyright 1992 William Clinger +; +; Permission to copy this software, in whole or in part, to use this +; software for any lawful purpose, and to redistribute this software +; is granted subject to the restriction that all copies made of this +; software must include this copyright notice in full. +; +; I also request that you send me a copy of any improvements that you +; make to this software so that they may be incorporated within it to +; the benefit of the Scheme community. + +;;;; Compiler for a . + +;;; The input is a and a syntactic environment. +;;; Syntactic environments are described in another file. + +;;; Transormer specs are in slib.texi. + +(define mw:pattern-variable-flag (list 'v)) +(define mw:ellipsis-pattern-flag (list 'e)) +(define mw:ellipsis-template-flag mw:ellipsis-pattern-flag) + +(define (mw:make-patternvar v rank) + (vector mw:pattern-variable-flag v rank)) +(define (mw:make-ellipsis-pattern P vars) + (vector mw:ellipsis-pattern-flag P vars)) +(define (mw:make-ellipsis-template T vars) + (vector mw:ellipsis-template-flag T vars)) + +(define (mw:patternvar? x) + (and (vector? x) + (= (vector-length x) 3) + (eq? (vector-ref x 0) mw:pattern-variable-flag))) + +(define (mw:ellipsis-pattern? x) + (and (vector? x) + (= (vector-length x) 3) + (eq? (vector-ref x 0) mw:ellipsis-pattern-flag))) + +(define (mw:ellipsis-template? x) + (and (vector? x) + (= (vector-length x) 3) + (eq? (vector-ref x 0) mw:ellipsis-template-flag))) + +(define (mw:patternvar-name V) (vector-ref V 1)) +(define (mw:patternvar-rank V) (vector-ref V 2)) +(define (mw:ellipsis-pattern P) (vector-ref P 1)) +(define (mw:ellipsis-pattern-vars P) (vector-ref P 2)) +(define (mw:ellipsis-template T) (vector-ref T 1)) +(define (mw:ellipsis-template-vars T) (vector-ref T 2)) + +(define (mw:pattern-variable v vars) + (cond ((null? vars) #f) + ((eq? v (mw:patternvar-name (car vars))) + (car vars)) + (else (mw:pattern-variable v (cdr vars))))) + +; Given a and a syntactic environment, +; returns a macro denotation. +; +; A macro denotation is of the form +; +; (macro ( ...) env) +; +; where each has been compiled as described above. + +(define (mw:compile-transformer-spec spec env) + (if (and (> (mw:safe-length spec) 1) + (eq? (mw:syntax-lookup env (car spec)) + mw:denote-of-syntax-rules)) + (let ((literals (cadr spec)) + (rules (cddr spec))) + (if (or (not (list? literals)) + (not (comlist:every (lambda (rule) + (and (= (mw:safe-length rule) 2) + (pair? (car rule)))) + rules))) + (mw:error "Malformed syntax-rules" spec)) + (list 'macro + (map (lambda (rule) + (mw:compile-rule rule literals env)) + rules) + env)) + (mw:error "Malformed syntax-rules" spec))) + +(define (mw:compile-rule rule literals env) + (mw:compile-pattern (cdr (car rule)) + literals + env + (lambda (compiled-rule patternvars) + ; should check uniqueness of pattern variables here!!!!! + (cons compiled-rule + (mw:compile-template + (cadr rule) + patternvars + env))))) + +(define (mw:compile-pattern P literals env k) + (define (loop P vars rank k) + (cond ((symbol? P) + (if (memq P literals) + (k P vars) + (let ((var (mw:make-patternvar P rank))) + (k var (cons var vars))))) + ((null? P) (k '() vars)) + ((pair? P) + (if (and (pair? (cdr P)) + (symbol? (cadr P)) + (eq? (mw:syntax-lookup env (cadr P)) + mw:denote-of-...)) + (if (null? (cddr P)) + (loop (car P) + '() + (+ rank 1) + (lambda (P vars1) + (k (mw:make-ellipsis-pattern P vars1) + (comlist:union vars1 vars)))) + (mw:error "Malformed pattern" P)) + (loop (car P) + vars + rank + (lambda (P1 vars) + (loop (cdr P) + vars + rank + (lambda (P2 vars) + (k (cons P1 P2) vars))))))) + ((vector? P) + (loop (vector->list P) + vars + rank + (lambda (P vars) + (k (vector P) vars)))) + (else (k P vars)))) + (loop P '() 0 k)) + +(define (mw:compile-template T vars env) + + (define (loop T inserted referenced rank escaped? k) + (cond ((symbol? T) + (let ((x (mw:pattern-variable T vars))) + (if x + (if (>= rank (mw:patternvar-rank x)) + (k x inserted (cons x referenced)) + (mw:error + "Too few ellipses follow pattern variable in template" + (mw:patternvar-name x))) + (k T (cons T inserted) referenced)))) + ((null? T) (k '() inserted referenced)) + ((pair? T) + (cond ((and (not escaped?) + (symbol? (car T)) + (eq? (mw:syntax-lookup env (car T)) + mw:denote-of-:::) + (pair? (cdr T)) + (null? (cddr T))) + (loop (cadr T) inserted referenced rank #t k)) + ((and (not escaped?) + (pair? (cdr T)) + (symbol? (cadr T)) + (eq? (mw:syntax-lookup env (cadr T)) + mw:denote-of-...)) + (loop1 T inserted referenced rank escaped? k)) + (else + (loop (car T) + inserted + referenced + rank + escaped? + (lambda (T1 inserted referenced) + (loop (cdr T) + inserted + referenced + rank + escaped? + (lambda (T2 inserted referenced) + (k (cons T1 T2) inserted referenced)))))))) + ((vector? T) + (loop (vector->list T) + inserted + referenced + rank + escaped? + (lambda (T inserted referenced) + (k (vector T) inserted referenced)))) + (else (k T inserted referenced)))) + + (define (loop1 T inserted referenced rank escaped? k) + (loop (car T) + inserted + '() + (+ rank 1) + escaped? + (lambda (T1 inserted referenced1) + (loop (cddr T) + inserted + (append referenced1 referenced) + rank + escaped? + (lambda (T2 inserted referenced) + (k (cons (mw:make-ellipsis-template + T1 + (comlist:remove-if-not + (lambda (var) (> (mw:patternvar-rank var) + rank)) + referenced1)) + T2) + inserted + referenced)))))) + + (loop T + '() + '() + 0 + #f + (lambda (T inserted referenced) + (list T inserted)))) + +; The pattern matcher. +; +; Given an input, a pattern, and two syntactic environments, +; returns a pattern variable environment (represented as an alist) +; if the input matches the pattern, otherwise returns #f. + +(define mw:empty-pattern-variable-environment + (list (mw:make-patternvar (string->symbol "") 0))) + +(define (mw:match F P env-def env-use) + + (define (match F P answer rank) + (cond ((null? P) + (and (null? F) answer)) + ((pair? P) + (and (pair? F) + (let ((answer (match (car F) (car P) answer rank))) + (and answer (match (cdr F) (cdr P) answer rank))))) + ((symbol? P) + (and (symbol? F) + (mw:same-denotation? (mw:syntax-lookup env-def P) + (mw:syntax-lookup env-use F)) + answer)) + ((mw:patternvar? P) + (cons (cons P F) answer)) + ((mw:ellipsis-pattern? P) + (match1 F P answer (+ rank 1))) + ((vector? P) + (and (vector? F) + (match (vector->list F) (vector-ref P 0) answer rank))) + (else (and (equal? F P) answer)))) + + (define (match1 F P answer rank) + (cond ((not (list? F)) #f) + ((null? F) + (append (map (lambda (var) (cons var '())) + (mw:ellipsis-pattern-vars P)) + answer)) + (else + (let* ((P1 (mw:ellipsis-pattern P)) + (answers (map (lambda (F) (match F P1 answer rank)) + F))) + (if (comlist:every identity answers) + (append (map (lambda (var) + (cons var + (map (lambda (answer) + (cdr (assq var answer))) + answers))) + (mw:ellipsis-pattern-vars P)) + answer) + #f))))) + + (match F P mw:empty-pattern-variable-environment 0)) + +(define (mw:rewrite T alist) + + (define (rewrite T alist rank) + (cond ((null? T) '()) + ((pair? T) + ((if (mw:ellipsis-pattern? (car T)) + append + cons) + (rewrite (car T) alist rank) + (rewrite (cdr T) alist rank))) + ((symbol? T) (cdr (assq T alist))) + ((mw:patternvar? T) (cdr (assq T alist))) + ((mw:ellipsis-template? T) + (rewrite1 T alist (+ rank 1))) + ((vector? T) + (list->vector (rewrite (vector-ref T 0) alist rank))) + (else T))) + + (define (rewrite1 T alist rank) + (let* ((T1 (mw:ellipsis-template T)) + (vars (mw:ellipsis-template-vars T)) + (rows (map (lambda (var) (cdr (assq var alist))) + vars))) + (map (lambda (alist) (rewrite T1 alist rank)) + (make-columns vars rows alist)))) + + (define (make-columns vars rows alist) + (define (loop rows) + (if (null? (car rows)) + '() + (cons (append (map (lambda (var row) + (cons var (car row))) + vars + rows) + alist) + (loop (map cdr rows))))) + (if (or (null? (cdr rows)) + (apply = (map length rows))) + (loop rows) + (mw:error "Use of macro is not consistent with definition" + vars + rows))) + + (rewrite T alist 0)) + +; Given a use of a macro, the syntactic environment of the use, +; and a continuation that expects a transcribed expression and +; a new environment in which to continue expansion, +; does the right thing. + +(define (mw:transcribe exp env-use k) + (let* ((m (mw:syntax-lookup env-use (car exp))) + (rules (macwork:rules m)) + (env-def (macwork:env m)) + (F (cdr exp))) + (define (loop rules) + (if (null? rules) + (mw:error "Use of macro does not match definition" exp) + (let* ((rule (car rules)) + (pattern (car rule)) + (alist (mw:match F pattern env-def env-use))) + (if alist + (let* ((template (cadr rule)) + (inserted (caddr rule)) + (alist2 (mw:rename-vars inserted)) + (newexp (mw:rewrite template (append alist2 alist)))) + (k newexp + (mw:syntax-alias env-use alist2 env-def))) + (loop (cdr rules)))))) + (loop rules))) diff --git a/obj2str.scm b/obj2str.scm new file mode 100644 index 0000000..19d8464 --- /dev/null +++ b/obj2str.scm @@ -0,0 +1,61 @@ +;;; "obj2str.scm", write objects to a string. +;Copyright (C) 1993, 1994 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'string-port) + +(define (object->string obj) + (cond ((symbol? obj) (symbol->string obj)) + ((number? obj) (number->string obj)) + (else + (call-with-output-string + (lambda (port) (write obj port)))))) + +; File: "obj2str.scm" (c) 1991, Marc Feeley + +;(require 'generic-write) + +; (object->string obj) returns the textual representation of 'obj' as a +; string. +; +; Note: (write obj) = (display (object->string obj)) + +;(define (object->string obj) +; (let ((result '())) +; (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t)) +; (reverse-string-append result))) + +; (object->limited-string obj limit) returns a string containing the first +; 'limit' characters of the textual representation of 'obj'. + +(define (object->limited-string obj limit) + (require 'generic-write) + (let ((result '()) (left limit)) + (generic-write obj #f #f + (lambda (str) + (let ((len (string-length str))) + (if (> len left) + (begin + (set! result (cons (substring str 0 left) result)) + (set! left 0) + #f) + (begin + (set! result (cons str result)) + (set! left (- left len)) + #t))))) + (reverse-string-append result))) diff --git a/object.scm b/object.scm new file mode 100644 index 0000000..4ba28fb --- /dev/null +++ b/object.scm @@ -0,0 +1,97 @@ +;;; "object.scm" Macroless Object System +;;;From: whumeniu@datap.ca (Wade Humeniuk) + +;;;Date: February 15, 1994 + +;; Object Construction: +;; 0 1 2 3 4 +;; #(object-tag get-method make-method! unmake-method! get-all-methods) + +(define object:tag "object") + +;;; This might be better done using COMLIST:DELETE-IF. +(define (object:removeq obj alist) + (if (null? alist) + alist + (if (eq? (caar alist) obj) + (cdr alist) + (cons (car alist) (object:removeq obj (cdr alist)))))) + +(define (get-all-methods obj) + (if (object? obj) + ((vector-ref obj 4)) + (slib:error "Cannot get methods on non-object: " obj))) + +(define (object? obj) + (and (vector? obj) + (eq? object:tag (vector-ref obj 0)))) + +(define (make-method! obj generic-method method) + (if (object? obj) + (if (procedure? method) + (begin + ((vector-ref obj 2) generic-method method) + method) + (slib:error "Method must be a procedure: " method)) + (slib:error "Cannot make method on non-object: " obj))) + +(define (get-method obj generic-method) + (if (object? obj) + ((vector-ref obj 1) generic-method) + (slib:error "Cannot get method on non-object: " obj))) + +(define (unmake-method! obj generic-method) + (if (object? obj) + ((vector-ref obj 3) generic-method) + (slib:error "Cannot unmake method on non-object: " obj))) + +(define (make-predicate! obj generic-predicate) + (if (object? obj) + ((vector-ref obj 2) generic-predicate (lambda (self) #t)) + (slib:error "Cannot make predicate on non-object: " obj))) + +(define (make-generic-method . exception-procedure) + (define generic-method + (lambda (obj . operands) + (if (object? obj) + (let ((object-method ((vector-ref obj 1) generic-method))) + (if object-method + (apply object-method (cons obj operands)) + (slib:error "Method not supported: " obj))) + (apply exception-procedure (cons obj operands))))) + + (if (not (null? exception-procedure)) + (if (procedure? (car exception-procedure)) + (set! exception-procedure (car exception-procedure)) + (slib:error "Exception Handler Not Procedure:")) + (set! exception-procedure + (lambda (obj . params) + (slib:error "Operation not supported: " obj)))) + generic-method) + +(define (make-generic-predicate) + (define generic-predicate + (lambda (obj) + (if (object? obj) + (if ((vector-ref obj 1) generic-predicate) + #t + #f) + #f))) + generic-predicate) + +(define (make-object . ancestors) + (define method-list + (apply append (map (lambda (obj) (get-all-methods obj)) ancestors))) + (define (make-method! generic-method method) + (set! method-list (cons (cons generic-method method) method-list)) + method) + (define (unmake-method! generic-method) + (set! method-list (object:removeq generic-method method-list)) + #t) + (define (all-methods) method-list) + (define (get-method generic-method) + (let ((method-def (assq generic-method method-list))) + (if method-def (cdr method-def) #f))) + (vector object:tag get-method make-method! unmake-method! all-methods)) + + diff --git a/paramlst.scm b/paramlst.scm new file mode 100644 index 0000000..f01788b --- /dev/null +++ b/paramlst.scm @@ -0,0 +1,215 @@ +;;; "paramlst.scm" passing parameters by name. +; Copyright 1995 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; Format of arity-spec: (name predicate conversion) + +(require 'common-list-functions) + +(define arity->arity-spec + (let ((table + `((nary + ,(lambda (a) #t) + ,identity) + (nary1 + ,(lambda (a) (not (null? a))) + ,identity) + (single + ,(lambda (a) (and (pair? a) (null? (cdr a)))) + ,car) + (optional + ,(lambda (a) (or (null? a) (and (pair? a) (null? (cdr a))))) + ,identity) + (boolean + ,(lambda (a) + (or (null? a) + (and (pair? a) (null? (cdr a)) (boolean? (car a))))) + ,(lambda (a) (if (null? a) #f (car a))))))) + (lambda (arity) + (assq arity table)))) + +(define (fill-empty-parameters defaults parameter-list) + (map (lambda (default parameter) + (cond ((null? (cdr parameter)) + (cons (car parameter) + (if default (default parameter-list) '()))) + (else parameter))) + defaults parameter-list)) + +(define (check-parameters checks parameter-list) + (for-each (lambda (check parameter) + (for-each + (lambda (p) + (cond ((and check (not (check p))) + (slib:error (car parameter) + "parameter is wrong type: " p)))) + (cdr parameter))) + checks parameter-list) + parameter-list) + +(define (check-arities arity-specs parameter-list) + (and (every identity arity-specs) + (every + (lambda (arity-spec param) + ((cadr arity-spec) (cdr param))) + arity-specs parameter-list))) + +(define (parameter-list->arglist positions arities parameter-list) + (and (= (length arities) (length positions) (length parameter-list)) + (let ((arity-specs (map arity->arity-spec arities)) + (ans (make-vector (length positions) #f))) + (and (check-arities arity-specs parameter-list) + (for-each + (lambda (pos arity-spec param) + (vector-set! ans (+ -1 pos) + ((caddr arity-spec) (cdr param)))) + positions arity-specs parameter-list) + (vector->list ans))))) + +(define (make-parameter-list parameter-names) + (map list parameter-names)) + +(define (parameter-list-ref parameter-list i) + (let ((ans (assoc i parameter-list))) + (and ans (cdr ans)))) + +(define (parameter-list-expand expanders parms) + (do ((lens (map length parms) (map length parms)) + (olens '() lens)) + ((equal? lens olens)) + (for-each (lambda (expander parm) + (cond + (expander + (for-each + (lambda (news) + (cond ((adjoin-parameters! parms news)) + (else (slib:error + "expanded feature unknown: " news)))) + (apply append + (map (lambda (p) + (cond ((expander p)) + ((not '()) '()) + (else (slib:error + "couldn't expand feature: " p)))) + (cdr parm))))))) + expanders + parms))) + +(define (adjoin-parameters! parameter-list . parameters) + (let ((apairs (map (lambda (param) + (cond ((pair? param) + (assoc (car param) parameter-list)) + (else (assoc param parameter-list)))) + parameters))) + (and (every identity apairs) ;same as APPLY AND? + (for-each + (lambda (apair param) + (cond ((pair? param) + (for-each (lambda (o) + (if (not (member o (cdr apair))) + (set-cdr! apair (cons o (cdr apair))))) + (cdr param))) + (else (if (not (memv #t (cdr apair))) + (set-cdr! apair (cons #t (cdr apair))))))) + apairs parameters) + parameter-list))) + +(define (getopt->parameter-list argc argv optnames arities types aliases) + (define (can-take-arg? opt) + (not (eq? (list-ref arities (position opt optnames)) + 'boolean))) + (define (coerce-val val curopt) + (define ntyp (list-ref types (position curopt optnames))) + (case ntyp + ((expression) val) + (else (coerce val ntyp)))) + (require 'getopt) + (let ((optlist '()) + (long-opt-list '()) + (optstring #f) + (parameter-list (make-parameter-list optnames)) + (curopt '*unclaimed-argument*)) + (set! aliases (map (lambda (alias) + (define str (string-copy (car alias))) + (do ((i (+ -1 (string-length str)) (+ -1 i))) + ((negative? i) (cons str (cdr alias))) + (cond ((char=? #\ (string-ref str i)) + (string-set! str i #\-))))) + aliases)) + (for-each + (lambda (alias) + (define opt (car alias)) + (cond ((not (string? opt))) + ((< 1 (string-length opt)) + (set! long-opt-list (cons opt long-opt-list))) + ((not (= 1 (string-length opt)))) + ((can-take-arg? (cadr alias)) + (set! optlist (cons (string-ref opt 0) + (cons #\: optlist)))) + (else (set! optlist (cons (string-ref opt 0) optlist))))) + aliases) + (set! optstring (list->string (cons #\: optlist))) + (let loop () + (let ((opt (getopt-- argc argv optstring))) + (case opt + ((#\: #\?) + (slib:error + 'getopt->parameter-list "unrecognized option" + getopt:opt)) + ((#f) + (cond ((and (< *optind* argc) + (string=? "-" (list-ref argv *optind*))) + (set! *optind* (+ 1 *optind*))) + ((< *optind* argc) + (cond ((and (member curopt optnames) + (adjoin-parameters! + parameter-list + (list curopt + (coerce-val (list-ref argv *optind*) + curopt)))) + (set! *optind* (+ 1 *optind*)) + (loop)) + (else (slib:error 'getopt->parameter-list curopt + (list-ref argv *optind*) + "not supported")))))) + (else + (cond ((char? opt) (set! opt (string opt)))) + (let ((topt (assoc opt aliases))) + (cond (topt (set! topt (cadr topt))) + (else (slib:error "Option not recognized -" opt))) + (cond + ((not (can-take-arg? topt)) + (adjoin-parameters! parameter-list (list topt #t))) + (*optarg* + (set! curopt topt) + (adjoin-parameters! parameter-list + (list topt (coerce-val *optarg* curopt)))) + (else + (set! curopt topt) + (rdms:warn + 'getopt->parameter-list "argument missing for option--" opt)))) + (loop))))) + parameter-list)) + +(define (getopt->arglist argc argv optnames positions + arities types defaults checks aliases) + (let* ((params (getopt->parameter-list + argc argv optnames arities types aliases)) + (fparams (fill-empty-parameters defaults params))) + (and (list? params) (check-parameters checks fparams)) + (and (list? params) (parameter-list->arglist positions arities fparams)))) diff --git a/plottest.scm b/plottest.scm new file mode 100644 index 0000000..20734f4 --- /dev/null +++ b/plottest.scm @@ -0,0 +1,47 @@ +;"plottest.scm" test charplot.scm +;Copyright (C) 1992 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'charplot) +(require 'random) + +(define strophoid + (let ((l '())) + (do ((x -1.0 (+ x 0.05))) + ((> x 4.0)) + (let* ((a (/ (- 2 x) (+ 2 x)))) + (if (>= a 0.0) + (let* ((y (* x (sqrt a)))) + (set! l (cons (cons x y) l)) + (set! l (cons (cons x (- y)) l)))))) + l)) + +(plot! strophoid "x" "y") (newline) + +(define unif + (let* ((l 6) + (v (make-vector l))) + (do ((i (- l 1) (- i 1))) + ((negative? i)) + (vector-set! v i (cons i 0))) + (do ((i 24 (- i 1)) + (r (random l) (random l))) + ((zero? i) (vector->list v)) + (set-cdr! (vector-ref v r) (+ 1 (cdr (vector-ref v r))))))) + +(plot! unif "n" "occur") diff --git a/pp.scm b/pp.scm new file mode 100644 index 0000000..1dbada0 --- /dev/null +++ b/pp.scm @@ -0,0 +1,12 @@ +;"pp.scm" Pretty-print + +(require 'generic-write) + +; (pretty-print obj port) pretty prints 'obj' on 'port'. The current +; output port is used if 'port' is not specified. + +(define (pp:pretty-print obj . opt) + (let ((port (if (pair? opt) (car opt) (current-output-port)))) + (generic-write obj #f 79 (lambda (s) (display s port) #t)))) + +(define pretty-print pp:pretty-print) diff --git a/ppfile.scm b/ppfile.scm new file mode 100644 index 0000000..4b21b6e --- /dev/null +++ b/ppfile.scm @@ -0,0 +1,70 @@ +;;;; "ppfile.scm". Pretty print a Scheme file. +;Copyright (C) 1993, 1994 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'pretty-print) + +(define (pprint-filter-file inport filter . optarg) + ((lambda (fun) + (if (input-port? inport) + (fun inport) + (call-with-input-file inport fun))) + (lambda (port) + ((lambda (fun) + (let ((outport + (if (null? optarg) (current-output-port) (car optarg)))) + (if (output-port? outport) + (fun outport) + (call-with-output-file outport fun)))) + (lambda (export) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* inport) + (letrec ((lp (lambda (c) + (cond ((eof-object? c)) + ((char-whitespace? c) + (display (read-char port) export) + (lp (peek-char port))) + ((char=? #\; c) + (cmt c)) + (else (sx))))) + (cmt (lambda (c) + (cond ((eof-object? c)) + ((char=? #\newline c) + (display (read-char port) export) + (lp (peek-char port))) + (else + (display (read-char port) export) + (cmt (peek-char port)))))) + (sx (lambda () + (let ((o (read port))) + (cond ((eof-object? o)) + (else + (pretty-print (filter o) export) + ;; pretty-print seems to have extra newline + (let ((c (peek-char port))) + (cond ((eqv? #\newline c) + (read-char port) + (set! c (peek-char port)))) + (lp c)))))))) + (lp (peek-char port))) + (set! *load-pathname* old-load-pathname))))))) + +(define (pprint-file ifile . optarg) + (pprint-filter-file ifile + (lambda (x) x) + (if (null? optarg) (current-output-port) (car optarg)))) diff --git a/primes.scm b/primes.scm new file mode 100644 index 0000000..a27b240 --- /dev/null +++ b/primes.scm @@ -0,0 +1,181 @@ +;; "primes.scm", test and generate prime numbers. +; Written by Michael H Coffin (mhc@edsdrd.eds.com) +; +; This code is in the public domain. + +;Date: Thu, 23 Feb 1995 07:47:49 +0500 +;From: mhc@edsdrd.eds.com (Michael H Coffin) +;; +;; Test numbers for primality using Rabin-Miller Monte-Carlo +;; primality test. +;; +;; Public functions: +;; +;; (primes start count . iter) +;; +;; (probably-prime? p . iter) +;; +;; +;; Please contact the author if you have problems or suggestions: +;; +;; Mike Coffin +;; 1196 Whispering Knoll +;; Rochester Hills, Mi. 48306 +;; +;; mhc@edsdrd.eds.com +;; + +(require 'random) + +;; The default number of times to perform the Rabin-Miller test. The +;; probability of a composite number passing the Rabin-Miller test for +;; primality with this many random numbers is at most +;; 1/(4^primes:iterations). The default yields about 1e-9. +;; +(define primes:iter 15) + +;; Is n probably prime? +;; +(define (primes:probably-prime? n . iter) + (let ((iter (if (null? iter) primes:iter (car iter)))) + (primes:prob-pr? n iter))) + + +;; Return a list of the first `number' odd probable primes less +;; than `start'. + +(define (primes:primes< start number . iter) + (let ((iter (if (null? iter) primes:iter (car iter)))) + (do ((candidate (if (odd? start) start (- start 1)) + (- candidate 2)) + (count 0) + (result '()) + ) + ((or (< candidate 3) (>= count number)) result) + (if (primes:prob-pr? candidate iter) + (begin + (set! count (1+ count)) + (set! result (cons candidate result))) + )))) + +(define (primes:primes> start number . iter) + (let ((iter (if (null? iter) primes:iter (car iter)))) + (do ((candidate (if (odd? start) start (+ 1 start)) + (+ 2 candidate)) + (count 0) + (result '()) + ) + ((= count number) (reverse result)) + (if (primes:prob-pr? candidate iter) + (begin + (set! count (1+ count)) + (set! result (cons candidate result))) + )))) + + +;; Is n probably prime? First we check for divisibility by small +;; primes; if it passes that, and it's less than the maximum small +;; prime squared, we try Rabin-Miller. +;; +(define (primes:prob-pr? n count) + (and (not (primes:dbsp? n)) + (or (< n (* primes:max-small-prime primes:max-small-prime)) + (primes:rm-prime? n count)))) + + +;; Is `n' Divisible By a Small Prime? +;; +(define (primes:dbsp? n) + (let ((limit (min (sqrt n) primes:max-small-prime)) + (divisible #f) + ) + (do ((i 0 (1+ i))) + ((let* ((divisor (array-ref primes:small-primes i))) + (set! divisible (= (modulo n divisor) 0)) + (or divisible (>= divisor limit))) + divisible) + ))) + + +;; Does `n' pass the R.-M. primality test for `m' random numbers? +;; +(define (primes:rm-prime? n m) + (do ((i 0 (1+ i)) + (x (+ 2 (random (- n 2))))) + ((or (= i m) (primes:rm-composite? n x)) + (= i m)))) + + +;; Does `x' prove `n' composite using Rabin-Miller? +;; +(define (primes:rm-composite? n x) + (let ((f (primes:extract2s (- n 1)))) + (primes:rm-comp? n (cdr f) (car f) x))) + + +;; Is `n' (where n-1 = 2^k * q) proven composite by `x'? +;; +(define (primes:rm-comp? n q k x) + (let ((y (primes:expt-mod x q n))) + (if (= y 1) + #f + (let loop ((j 0) (y y)) + (cond ((= j k) #t) + ((= y (- n 1)) #f) + ((= y 1) #t) + (else (loop (1+ j) (primes:expt-mod y 2 n))) + ))))) + + +;; Extract factors of 2; that is, factor x as 2^k * q +;; and return (k . q) +;; +(define (primes:extract2s x) + (do ((k 0 (1+ k)) + (q x (quotient q 2))) + ((odd? q) (cons k q)) + )) + + +;; Raise `base' to the power `exp' modulo `modulus' Could use the +;; modulo package, but we only need this function (and besides, this +;; implementation is quite a bit faster). +;; +(define (primes:expt-mod base exp modulus) + (do ((y 1) + (k exp (quotient k 2)) + (z base (modulo (* z z) modulus))) + ((= k 0) y) + (if (odd? k) + (set! y (modulo (* y z) modulus))) + )) + +;; This table seems big enough so that making it larger really +;; doesn't have much effect. +;; +(define primes:max-small-prime 997) + +(define primes:small-primes + #( 2 3 5 7 11 13 17 19 23 29 + 31 37 41 43 47 53 59 61 67 71 + 73 79 83 89 97 101 103 107 109 113 + 127 131 137 139 149 151 157 163 167 173 + 179 181 191 193 197 199 211 223 227 229 + 233 239 241 251 257 263 269 271 277 281 + 283 293 307 311 313 317 331 337 347 349 + 353 359 367 373 379 383 389 397 401 409 + 419 421 431 433 439 443 449 457 461 463 + 467 479 487 491 499 503 509 521 523 541 + 547 557 563 569 571 577 587 593 599 601 + 607 613 617 619 631 641 643 647 653 659 + 661 673 677 683 691 701 709 719 727 733 + 739 743 751 757 761 769 773 787 797 809 + 811 821 823 827 829 839 853 857 859 863 + 877 881 883 887 907 911 919 929 937 941 + 947 953 967 971 977 983 991 997 )) + +(define primes< primes:primes<) +(define primes> primes:primes>) +(define probably-prime? primes:probably-prime?) + +(provide 'primes) diff --git a/printf.scm b/printf.scm new file mode 100644 index 0000000..dffe90d --- /dev/null +++ b/printf.scm @@ -0,0 +1,278 @@ +;;;; "printf.scm" Implementation of standard C functions for Scheme +;;; Copyright (C) 1991-1993, 1996 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'string-case) + +;;; Floating point is not handled yet. + +(define (stdio:iprintf out-proc format-string . args) + (define char-count 0) + (define (out c) + (cond ((char? c) (set! char-count (+ 1 char-count))) + (else (set! char-count (+ (string-length c) char-count)))) + (out-proc c) #t) + (cond + ((not (equal? "" format-string)) + (let ((pos -1) + (fl (string-length format-string)) + (fc (string-ref format-string 0))) + + (define (advance) + (set! pos (+ 1 pos)) + (cond ((>= pos fl) (set! fc #f)) + (else (set! fc (string-ref format-string pos))))) + (define (must-advance) + (set! pos (+ 1 pos)) + (cond ((>= pos fl) (incomplete)) + (else (set! fc (string-ref format-string pos))))) + (define (end-of-format?) + (>= pos fl)) + (define (incomplete) + (slib:error 'printf "conversion specification incomplete" + format-string)) + + (let loop ((args args)) + (advance) + (cond + ((end-of-format?)) + ((eqv? #\\ fc);;Emulating C strings may not be a good idea. + (must-advance) + (case fc + ((#\n #\N) (out #\newline)) + ((#\t #\T) (out slib:tab)) + ((#\r #\R) (out #\return)) + ((#\f #\F) (out slib:form-feed)) + ((#\newline) #f) + (else (out fc))) + (loop args)) + ((eqv? #\% fc) + (must-advance) + (let ((left-adjust #f) ;- + (signed #f) ;+ + (blank #f) + (alternate-form #f) ;# + (leading-0s #f) ;0 + (width 0) + (precision -1) + (type-modifier #f) + (read-format-number + (lambda () + (cond + ((eqv? #\* fc) ; GNU extension + (must-advance) + (let ((ans (car args))) + (set! args (cdr args)) + ans)) + (else + (do ((c fc fc) + (accum 0 (+ (* accum 10) + (string->number (string c))))) + ((not (char-numeric? fc)) accum) + (must-advance))))))) + (define integer-pad + (lambda (s radix) + (cond ((not (negative? precision)) + (set! leading-0s #f))) + (let* ((pre + (cond ((equal? "" s) "") + ((eqv? #\- (string-ref s 0)) + (set! s (substring s 1 (string-length s))) + "-") + (signed "+") + (blank " ") + ((equal? "" s) "") + (alternate-form + (case radix + ((8) "0") + ((16) "0x") + (else ""))) + (else ""))) + (length-so-far (+ (string-length pre) + (string-length s)))) + (cond ((<= width length-so-far) + (string-append pre s)) + (left-adjust + (string-append + pre s + (make-string (- width length-so-far) #\ ))) + (leading-0s + (string-append + pre (make-string (- width length-so-far) #\0) + s)) + (else + (string-append + (make-string (- width length-so-far) #\ ) + pre s)))))) + + (do () + ((case fc + ((#\-) (set! left-adjust #t) #f) + ((#\+) (set! signed #t) #f) + ((#\ ) (set! blank #t) #f) + ((#\#) (set! alternate-form #t) #f) + ((#\0) (set! leading-0s #t) #f) + (else #t))) + (must-advance)) + (cond (left-adjust (set! leading-0s #f))) + (cond (signed (set! blank #f))) + + (set! width (read-format-number)) + (cond ((negative? width) + (set! left-adjust #t) + (set! width (- width)))) + (cond ((eqv? #\. fc) + (must-advance) + (set! precision (read-format-number)))) + (case fc ;Ignore these specifiers + ((#\l #\L #\h) + (set! type-modifier fc) + (must-advance))) + + (case fc + ;; only - is allowed between % and c + ((#\c #\C) ; C is enhancement + (out (string (car args))) + (loop (cdr args))) + + ;; only - flag, no type-modifiers + ((#\s #\S) ; S is enhancement + (let ((s (cond + ((symbol? (car args)) (symbol->string (car args))) + ((not (car args)) "(NULL)") + (else (car args))))) + (cond ((not (or (negative? precision) + (>= precision (string-length s)))) + (set! s (substring s 0 precision)))) + (out + (cond + ((<= width (string-length s)) s) + (left-adjust + (string-append + s (make-string (- width (string-length s)) #\ ))) + (else + (string-append (make-string (- width (string-length s)) + (if leading-0s #\0 #\ )) s)))) + (loop (cdr args)))) + + ;; SLIB extension + ((#\a #\A) ;#\y #\Y are pretty-print + (require 'generic-write) + (let ((os "") (pr precision)) + (generic-write + (car args) (not alternate-form) #f + (cond ((and left-adjust (negative? pr)) + out) + (left-adjust + (lambda (s) + (define sl (- pr (string-length s))) + (set! pr (cond ((negative? sl) + (out (substring s 0 pr)) 0) + (else (out s) sl))) + (positive? sl))) + ((negative? pr) + (set! pr width) + (lambda (s) + (set! pr (- pr (string-length s))) + (cond ((not os) (out s)) + ((negative? pr) + (out os) + (set! os #f) + (out s)) + (else (set! os (string-append os s)))) + #t)) + (else + (lambda (s) + (define sl (- pr (string-length s))) + (cond ((negative? sl) + (set! os (string-append + os (substring s 0 pr)))) + (else (set! os (string-append os s)))) + (set! pr sl) + (positive? sl))))) + (cond (left-adjust + (cond + ((> width (- precision pr)) + (out (make-string (- width (- precision pr)) + #\ ))))) + ((not os)) + ((<= width (string-length os)) (out os)) + (else + (out (make-string (- width (string-length os)) #\ )) + (out os)))) + (loop (cdr args))) + + ((#\d #\D #\i #\I #\u #\U) + (out (integer-pad + (cond ((symbol? (car args)) + (symbol->string (car args))) + ((number? (car args)) + (number->string (car args))) + ((not (car args)) "0") + (else "1")) + 10)) + (loop (cdr args))) + ((#\o #\O) + (out (integer-pad (number->string (car args) 8) 8)) + (loop (cdr args))) + ((#\x #\X) + (out + ((if (char-upper-case? fc) string-upcase string-downcase) + (integer-pad (number->string (car args) 16) 16))) + (loop (cdr args))) + ((#\%) (out #\%) + (loop args)) + (else + (cond ((end-of-format?) (incomplete)) + (else (out #\%) (out fc) (out #\?) + (loop args))))))) + (else (out fc) + (loop args))))))) + char-count) ; return number of characters output. + +(define (stdio:printf format . args) + (apply stdio:iprintf display format args)) + +(define (stdio:fprintf port format . args) + (if (equal? port (current-output-port)) + (apply stdio:iprintf display format args) + (apply stdio:iprintf (lambda (x) (display x port)) format args))) + +(define (stdio:sprintf s format . args) + (let ((p 0) (end (string-length s))) + (apply stdio:iprintf + (lambda (x) + (cond ((string? x) + (do ((i 0 (+ i 1))) + ((>= i (min (string-length x) end))) + (string-set! s p (string-ref x i)) + (set! p (+ p 1)))) + ((>= p end)) + ((char? x) + (string-set! s p x) + (set! p (+ p 1))) + (else + (string-set! s p #\?) + (set! p (+ p 1))))) + format + args) + p)) + +(define printf stdio:printf) +(define fprintf stdio:fprintf) +(define sprintf stdio:sprintf) diff --git a/priorque.scm b/priorque.scm new file mode 100644 index 0000000..927ffbe --- /dev/null +++ b/priorque.scm @@ -0,0 +1,141 @@ +;;;; "priorque.scm" priority queues for Scheme. +;;; Copyright (C) 1992, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; Algorithm from: +;;; Introduction to Algorithms by T. Cormen, C. Leiserson, R. Rivest. +;;; 1989 MIT Press. + +(require 'record) + +;; Record type. +(define heap:rtd (make-record-type "heap" '(array size heap s (vector-length ra)) + (let ((nra (make-vector (+ s (quotient s 2))))) + (do ((i (+ -1 (vector-length ra)) (+ -1 i))) + ((negative? i) (am a nra)) + (vector-set! nra i (vector-ref ra i))))) + (sm a s))))) + +(define (heap:parent i) (quotient i 2)) +(define (heap:left i) (* 2 i)) +(define (heap:right i) (+ 1 (* 2 i))) + +(define (heap:heapify a i) + (let* ((l (heap:left i)) + (r (heap:right i)) + (largest (if (and (<= l (heap:length a)) + ((heap:heap i 1) + ((heap:heap?)) + (heap-insert! heap #\A) + (heap-insert! heap #\Z) + (heap-insert! heap #\G) + (heap-insert! heap #\B) + (heap-insert! heap #\G) + (heap-insert! heap #\Q) + (heap-insert! heap #\S) + (heap-insert! heap #\R) + (print (heap-extract-max! heap)) + (print (heap-extract-max! heap)) + (print (heap-extract-max! heap)) + (print (heap-extract-max! heap)) + (print (heap-extract-max! heap)) + (print (heap-extract-max! heap)) + (print (heap-extract-max! heap)) + (print (heap-extract-max! heap)))) diff --git a/process.scm b/process.scm new file mode 100644 index 0000000..6b0acc3 --- /dev/null +++ b/process.scm @@ -0,0 +1,68 @@ +;;;; "process.scm", Multi-Processing for Scheme +;;; Copyright (C) 1992, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'full-continuation) +(require 'queue) + +(define (add-process! thunk1) + (cond ((procedure? thunk1) + (defer-ints) + (enqueue! process:queue thunk1) + (allow-ints)) + (else (slib:error "add-process!: wrong type argument " thunk1)))) + +(define (process:schedule!) + (defer-ints) + (cond ((queue-empty? process:queue) (allow-ints) + 'still-running) + (else (call-with-current-continuation + (lambda (cont) + (enqueue! process:queue cont) + (let ((proc (dequeue! process:queue))) + (allow-ints) + (proc 'run)) + (kill-process!)))))) + +(define (kill-process!) + (defer-ints) + (cond ((queue-empty? process:queue) (allow-ints) + (slib:exit)) + (else (let ((proc (dequeue! process:queue))) + (allow-ints) + (proc 'run)) + (kill-process!)))) + +(define ints-disabled #f) +(define alarm-deferred #f) + +(define (defer-ints) (set! ints-disabled #t)) + +(define (allow-ints) + (set! ints-disabled #f) + (cond (alarm-deferred + (set! alarm-deferred #f) + (alarm-interrupt)))) + +;;; Make THE process queue. +(define process:queue (make-queue)) + +(define (alarm-interrupt) + (alarm 1) + (if ints-disabled (set! alarm-deferred #t) + (process:schedule!))) diff --git a/promise.scm b/promise.scm new file mode 100644 index 0000000..f38aebf --- /dev/null +++ b/promise.scm @@ -0,0 +1,29 @@ +;;;"promise.scm" promise for force and delay +;;; From Revised^4 Report on the Algorithmic Language Scheme +;;; Editors: William Clinger and Jonathon Rees +; +; We intend this report to belong to the entire Scheme community, and so +; we grant permission to copy it in whole or in part without fee. In +; particular, we encourage implementors of Scheme to use this report as +; a starting point for manuals and other documentation, modifying it as +; necessary. + +(define promise:force (lambda (object) (object))) + +(define make-promise + (lambda (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)))))))) + +;;; change occurences of (DELAY ) to +;;; (MAKE-PROMISE (LAMBDA () )) +;;; and (define force promise:force) diff --git a/qp.scm b/qp.scm new file mode 100644 index 0000000..3eed54d --- /dev/null +++ b/qp.scm @@ -0,0 +1,149 @@ +;;;; "qp.scm" Print finite length representation for any Scheme object. +;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define *qp-width* (output-port-width (current-output-port))) + +(define qp:qpn + (let ((newline newline) (apply apply)) + (lambda objs (apply qp:qp objs) (newline)))) + +(define qp:qpr + (let ((- -) (apply apply) (length length) (list-ref list-ref)) + (lambda objs (apply qp:qpn objs) + (list-ref objs (- (length objs) 1))))) + +(define qp:qp + (let + ((+ +) (- -) (< <) (= =) (>= >=) (apply apply) (boolean? boolean?) + (car car) (cdr cdr) (char? char?) (display display) (eq? eq?) + (for-each for-each) (input-port? input-port?) + (not not) (null? null?) (number->string number->string) + (number? number?) (output-port? output-port?) (eof-object? eof-object?) + (procedure? procedure?) (string-length string-length) + (string? string?) (substring substring) + (symbol->string symbol->string) (symbol? symbol?) + (vector-length vector-length) (vector-ref vector-ref) + (vector? vector?) (write write) (quotient quotient)) + (letrec + ((num-cdrs + (lambda (pairs max-cdrs) + (cond + ((null? pairs) 0) + ((< max-cdrs 1) 1) + ((pair? pairs) (+ 1 (num-cdrs (cdr pairs) (- max-cdrs 1)))) + (else 1)))) + + (l-elt-room + (lambda (room pairs) + (quotient room (num-cdrs pairs (quotient room 8))))) + + (qp-pairs + (lambda (cdrs room) + (cond + ((null? cdrs) 0) + ((not (pair? cdrs)) + (display " . ") + (+ 3 (qp-obj cdrs (l-elt-room (- room 3) cdrs)))) + ((< 11 room) + (display #\ ) + ((lambda (used) + (+ (qp-pairs (cdr cdrs) (- room used)) used)) + (+ 1 (qp-obj (car cdrs) (l-elt-room (- room 1) cdrs))))) + (else + (display " ...") 4)))) + + (v-elt-room + (lambda (room vleft) + (quotient room (min vleft (quotient room 8))))) + + (qp-vect + (lambda (vect i room) + (cond + ((= (vector-length vect) i) 0) + ((< 11 room) + (display #\ ) + ((lambda (used) + (+ (qp-vect vect (+ i 1) (- room used)) used)) + (+ 1 (qp-obj (vector-ref vect i) + (v-elt-room (- room 1) + (- (vector-length vect) i)))))) + (else + (display " ...") 4)))) + + (qp-string + (lambda (str room) + (cond + ((>= (string-length str) room 3) + (display (substring str 0 (- room 3))) + (display "...") + room) + (else + (display str) + (string-length str))))) + + (qp-obj + (lambda (obj room) + (cond + ((null? obj) (write obj) 2) + ((boolean? obj) (write obj) 2) + ((char? obj) (write obj) 8) + ((number? obj) (qp-string (number->string obj) room)) + ((string? obj) + (display #\") + ((lambda (ans) (display #\") ans) + (+ 2 (qp-string obj (- room 2))))) + ((symbol? obj) (qp-string (symbol->string obj) room)) + ((input-port? obj) (display "#[input]") 8) + ((output-port? obj) (display "#[output]") 9) + ((procedure? obj) (display "#[proc]") 7) + ((eof-object? obj) (display "#[eof]") 6) + ((vector? obj) + (set! room (- room 3)) + (display "#(") + ((lambda (used) (display #\)) (+ used 3)) + (cond + ((= 0 (vector-length obj)) 0) + ((< room 8) (display "...") 3) + (else + ((lambda (used) (+ (qp-vect obj 1 (- room used)) used)) + (qp-obj (vector-ref obj 0) + (v-elt-room room (vector-length obj)))))))) + ((pair? obj) + (set! room (- room 2)) + (display #\() + ((lambda (used) (display #\)) (+ 2 used)) + (if (< room 8) (begin (display "...") 3) + ((lambda (used) + (+ (qp-pairs (cdr obj) (- room used)) used)) + (qp-obj (car obj) (l-elt-room room obj)))))) + (else (display "#[unknown]") 10))))) + + (lambda objs + (cond + ((= 0 *qp-width*) + (for-each (lambda (x) (write x) (display #\ )) objs) + (newline)) + (else + (qp-pairs (cdr objs) + (- *qp-width* + (qp-obj (car objs) (l-elt-room *qp-width* objs)))))))))) + +(define qp qp:qp) +(define qpn qp:qpn) +(define qpr qp:qpr) diff --git a/queue.scm b/queue.scm new file mode 100644 index 0000000..4557746 --- /dev/null +++ b/queue.scm @@ -0,0 +1,72 @@ +; "queue.scm" Queues/Stacks for Scheme +; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. +; +; This code is in the public domain. + +(require 'record) + +; Elements in a queue are stored in a list. The last pair in the list +; is stored in the queue type so that datums can be added in constant +; time. + +(define queue:record-type + (make-record-type "queue" '(first-pair last-pair))) +(define make-queue + (let ((construct-queue (record-constructor queue:record-type))) + (lambda () + (construct-queue '() '())))) + +(define queue? (record-predicate queue:record-type)) + +(define queue:first-pair (record-accessor queue:record-type + 'first-pair)) +(define queue:set-first-pair! (record-modifier queue:record-type + 'first-pair)) +(define queue:last-pair (record-accessor queue:record-type + 'last-pair)) +(define queue:set-last-pair! (record-modifier queue:record-type + 'last-pair)) + +(define (queue-empty? q) + (null? (queue:first-pair q))) + +(define (queue-front q) + (let ((first-pair (queue:first-pair q))) + (if (null? first-pair) + (slib:error "queue is empty" q)) + (car first-pair))) + +(define (queue-rear q) + (let ((last-pair (queue:last-pair q))) + (if (null? last-pair) + (slib:error "queue is empty" q)) + (car last-pair))) + +(define (queue-push! q datum) + (let* ((old-first-pair (queue:first-pair q)) + (new-first-pair (cons datum old-first-pair))) + (queue:set-first-pair! q new-first-pair) + (if (null? old-first-pair) + (queue:set-last-pair! q new-first-pair))) + q) + +(define (enqueue! q datum) + (let ((new-pair (cons datum '()))) + (cond ((null? (queue:first-pair q)) + (queue:set-first-pair! q new-pair)) + (else + (set-cdr! (queue:last-pair q) new-pair))) + (queue:set-last-pair! q new-pair)) + q) + +(define (dequeue! q) + (let ((first-pair (queue:first-pair q))) + (if (null? first-pair) + (slib:error "queue is empty" q)) + (let ((first-cdr (cdr first-pair))) + (queue:set-first-pair! q first-cdr) + (if (null? first-cdr) + (queue:set-last-pair! q '())) + (car first-pair)))) + +(define queue-pop! dequeue!) diff --git a/r4rsyn.scm b/r4rsyn.scm new file mode 100644 index 0000000..500d68c --- /dev/null +++ b/r4rsyn.scm @@ -0,0 +1,542 @@ +;;; "r4rsyn.scm" R4RS syntax -*-Scheme-*- +;;; Copyright (c) 1989-91 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of Electrical +;;; Engineering and Computer Science. Permission to copy this +;;; software, to redistribute it, and to use it for any purpose is +;;; granted, subject to the following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions +;;; that they make, so that these may be included in future releases; +;;; and (b) to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the +;;; usual standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation +;;; of this software will be error-free, and MIT is under no +;;; obligation to provide any services, by way of maintenance, update, +;;; or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the Massachusetts +;;; Institute of Technology nor of any adaptation thereof in any +;;; advertising, promotional, or sales literature without prior +;;; written consent from MIT in each case. + +;;;; R4RS Syntax + +(define scheme-syntactic-environment #f) + +(define (initialize-scheme-syntactic-environment!) + (set! scheme-syntactic-environment + ((compose-macrologies + (make-core-primitive-macrology) + (make-binding-macrology syntactic-binding-theory + 'LET-SYNTAX 'LETREC-SYNTAX 'DEFINE-SYNTAX) + (make-binding-macrology variable-binding-theory + 'LET 'LETREC 'DEFINE) + (make-r4rs-primitive-macrology) + (make-core-expander-macrology) + (make-syntax-rules-macrology)) + root-syntactic-environment))) + +;;;; Core Primitives + +(define (make-core-primitive-macrology) + (make-primitive-macrology + (lambda (define-classifier define-compiler) + + (define-classifier 'BEGIN + (lambda (form environment definition-environment) + (syntax-check '(KEYWORD * FORM) form) + (make-body-item (classify/subforms (cdr form) + environment + definition-environment)))) + + (define-compiler 'DELAY + (lambda (form environment) + (syntax-check '(KEYWORD EXPRESSION) form) + (output/delay + (compile/subexpression (cadr form) + environment)))) + + (define-compiler 'IF + (lambda (form environment) + (syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION) form) + (output/conditional + (compile/subexpression (cadr form) environment) + (compile/subexpression (caddr form) environment) + (if (null? (cdddr form)) + (output/unspecific) + (compile/subexpression (cadddr form) + environment))))) + + (define-compiler 'QUOTE + (lambda (form environment) + environment ;ignore + (syntax-check '(KEYWORD DATUM) form) + (output/literal-quoted (strip-syntactic-closures (cadr form)))))))) + +;;;; Bindings + +(define (make-binding-macrology binding-theory + let-keyword letrec-keyword define-keyword) + (make-primitive-macrology + (lambda (define-classifier define-compiler) + + (let ((pattern/let-like + '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM)) + (compile/let-like + (lambda (form environment body-environment output/let) + ;; Force evaluation order. + (let ((bindings + (let loop + ((bindings + (map (lambda (binding) + (cons (car binding) + (classify/subexpression + (cadr binding) + environment))) + (cadr form)))) + (if (null? bindings) + '() + (let ((binding + (binding-theory body-environment + (caar bindings) + (cdar bindings)))) + (if binding + (cons binding (loop (cdr bindings))) + (loop (cdr bindings)))))))) + (output/let (map car bindings) + (map (lambda (binding) + (compile-item/expression (cdr binding))) + bindings) + (compile-item/expression + (classify/body (cddr form) + body-environment))))))) + + (define-compiler let-keyword + (lambda (form environment) + (syntax-check pattern/let-like form) + (compile/let-like form + environment + (internal-syntactic-environment environment) + output/let))) + + (define-compiler letrec-keyword + (lambda (form environment) + (syntax-check pattern/let-like form) + (let ((environment (internal-syntactic-environment environment))) + (reserve-names! (map car (cadr form)) environment) + (compile/let-like form + environment + environment + output/letrec))))) + + (define-classifier define-keyword + (lambda (form environment definition-environment) + (syntax-check '(KEYWORD IDENTIFIER EXPRESSION) form) + (syntactic-environment/define! definition-environment + (cadr form) + (make-reserved-name-item)) + (make-definition-item binding-theory + (cadr form) + (make-promise + (lambda () + (classify/subexpression + (caddr form) + environment))))))))) + +;;;; Bodies + +(define (classify/body forms environment) + (let ((environment (internal-syntactic-environment environment))) + (let forms-loop + ((forms forms) + (bindings '())) + (if (null? forms) + (syntax-error "no expressions in body" + "") + (let items-loop + ((items + (item->list + (classify/subform (car forms) + environment + environment))) + (bindings bindings)) + (cond ((null? items) + (forms-loop (cdr forms) + bindings)) + ((definition-item? (car items)) + (items-loop (cdr items) + (let ((binding + (bind-definition-item! environment + (car items)))) + (if binding + (cons binding bindings) + bindings)))) + (else + (let ((body + (make-body-item + (append items + (flatten-body-items + (classify/subforms + (cdr forms) + environment + environment)))))) + (make-expression-item + (lambda () + (output/letrec + (map car bindings) + (map (lambda (binding) + (compile-item/expression (cdr binding))) + bindings) + (compile-item/expression body))) forms))))))))) + +;;;; R4RS Primitives + +(define (make-r4rs-primitive-macrology) + (make-primitive-macrology + (lambda (define-classifier define-compiler) + + (define (transformer-keyword expander->classifier) + (lambda (form environment definition-environment) + definition-environment ;ignore + (syntax-check '(KEYWORD EXPRESSION) form) + (let ((item + (classify/subexpression (cadr form) + scheme-syntactic-environment))) + (let ((transformer (base:eval (compile-item/expression item)))) + (if (procedure? transformer) + (make-keyword-item + (expander->classifier transformer environment) item) + (syntax-error "transformer not a procedure" + transformer)))))) + + (define-classifier 'TRANSFORMER + ;; "Syntactic Closures" transformer + (transformer-keyword sc-expander->classifier)) + + (define-classifier 'ER-TRANSFORMER + ;; "Explicit Renaming" transformer + (transformer-keyword er-expander->classifier)) + + (define-compiler 'LAMBDA + (lambda (form environment) + (syntax-check '(KEYWORD R4RS-BVL + FORM) form) + (let ((environment (internal-syntactic-environment environment))) + ;; Force order -- bind names before classifying body. + (let ((bvl-description + (let ((rename + (lambda (identifier) + (bind-variable! environment identifier)))) + (let loop ((bvl (cadr form))) + (cond ((null? bvl) + '()) + ((pair? bvl) + (cons (rename (car bvl)) (loop (cdr bvl)))) + (else + (rename bvl))))))) + (output/lambda bvl-description + (compile-item/expression + (classify/body (cddr form) + environment))))))) + + (define-compiler 'SET! + (lambda (form environment) + (syntax-check '(KEYWORD FORM EXPRESSION) form) + (output/assignment + (let loop + ((form (cadr form)) + (environment environment)) + (cond ((identifier? form) + (let ((item + (syntactic-environment/lookup environment form))) + (if (variable-item? item) + (variable-item/name item) + (slib:error "target of assignment not a variable" + form)))) + ((syntactic-closure? form) + (let ((form (syntactic-closure/form form)) + (environment + (filter-syntactic-environment + (syntactic-closure/free-names form) + environment + (syntactic-closure/environment form)))) + (loop form + environment))) + (else + (slib:error "target of assignment not an identifier" + form)))) + (compile/subexpression (caddr form) + environment)))) + + ;; end MAKE-R4RS-PRIMITIVE-MACROLOGY + ))) + +;;;; Core Expanders + +(define (make-core-expander-macrology) + (make-er-expander-macrology + (lambda (define-expander base-environment) + + (let ((keyword (make-syntactic-closure base-environment '() 'DEFINE))) + (define-expander 'DEFINE + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '((IDENTIFIER . R4RS-BVL) + FORM) (cdr form)) + `(,keyword ,(caadr form) + (,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form))) + `(,keyword ,@(cdr form)))))) + + (let ((keyword (make-syntactic-closure base-environment '() 'LET))) + (define-expander 'LET + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '(IDENTIFIER (* (IDENTIFIER EXPRESSION)) + FORM) + (cdr form)) + (let ((name (cadr form)) + (bindings (caddr form))) + `((,(rename 'LETREC) + ((,name (,(rename 'LAMBDA) ,(map car bindings) ,@(cdddr form)))) + ,name) + ,@(map cadr bindings))) + `(,keyword ,@(cdr form)))))) + + (define-expander 'LET* + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '((* (IDENTIFIER EXPRESSION)) + FORM) (cdr form)) + (let ((bindings (cadr form)) + (body (cddr form)) + (keyword (rename 'LET))) + (if (null? bindings) + `(,keyword ,bindings ,@body) + (let loop ((bindings bindings)) + (if (null? (cdr bindings)) + `(,keyword ,bindings ,@body) + `(,keyword (,(car bindings)) + ,(loop (cdr bindings))))))) + (ill-formed-syntax form)))) + + (define-expander 'AND + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '(* EXPRESSION) (cdr form)) + (let ((operands (cdr form))) + (if (null? operands) + `#T + (let ((if-keyword (rename 'IF))) + (let loop ((operands operands)) + (if (null? (cdr operands)) + (car operands) + `(,if-keyword ,(car operands) + ,(loop (cdr operands)) + #F)))))) + (ill-formed-syntax form)))) + + (define-expander 'OR + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '(* EXPRESSION) (cdr form)) + (let ((operands (cdr form))) + (if (null? operands) + `#F + (let ((let-keyword (rename 'LET)) + (if-keyword (rename 'IF)) + (temp (rename 'TEMP))) + (let loop ((operands operands)) + (if (null? (cdr operands)) + (car operands) + `(,let-keyword ((,temp ,(car operands))) + (,if-keyword ,temp + ,temp + ,(loop (cdr operands))))))))) + (ill-formed-syntax form)))) + + (define-expander 'CASE + (lambda (form rename compare) + (if (syntax-match? '(EXPRESSION + (DATUM + EXPRESSION)) (cdr form)) + (letrec + ((process-clause + (lambda (clause rest) + (cond ((null? (car clause)) + (process-rest rest)) + ((and (identifier? (car clause)) + (compare (rename 'ELSE) (car clause)) + (null? rest)) + `(,(rename 'BEGIN) ,@(cdr clause))) + ((list? (car clause)) + `(,(rename 'IF) (,(rename 'MEMV) ,(rename 'TEMP) + ',(car clause)) + (,(rename 'BEGIN) ,@(cdr clause)) + ,(process-rest rest))) + (else + (syntax-error "ill-formed clause" clause))))) + (process-rest + (lambda (rest) + (if (null? rest) + (unspecific-expression) + (process-clause (car rest) (cdr rest)))))) + `(,(rename 'LET) ((,(rename 'TEMP) ,(cadr form))) + ,(process-clause (caddr form) (cdddr form)))) + (ill-formed-syntax form)))) + + (define-expander 'COND + (lambda (form rename compare) + (letrec + ((process-clause + (lambda (clause rest) + (cond + ((or (not (list? clause)) + (null? clause)) + (syntax-error "ill-formed clause" clause)) + ((and (identifier? (car clause)) + (compare (rename 'ELSE) (car clause))) + (cond + ((or (null? (cdr clause)) + (and (identifier? (cadr clause)) + (compare (rename '=>) (cadr clause)))) + (syntax-error "ill-formed ELSE clause" clause)) + ((not (null? rest)) + (syntax-error "misplaced ELSE clause" clause)) + (else + `(,(rename 'BEGIN) ,@(cdr clause))))) + ((null? (cdr clause)) + `(,(rename 'OR) ,(car clause) ,(process-rest rest))) + ((and (identifier? (cadr clause)) + (compare (rename '=>) (cadr clause))) + (if (and (pair? (cddr clause)) + (null? (cdddr clause))) + `(,(rename 'LET) + ((,(rename 'TEMP) ,(car clause))) + (,(rename 'IF) ,(rename 'TEMP) + (,(caddr clause) ,(rename 'TEMP)) + ,(process-rest rest))) + (syntax-error "ill-formed => clause" clause))) + (else + `(,(rename 'IF) ,(car clause) + (,(rename 'BEGIN) ,@(cdr clause)) + ,(process-rest rest)))))) + (process-rest + (lambda (rest) + (if (null? rest) + (unspecific-expression) + (process-clause (car rest) (cdr rest)))))) + (let ((clauses (cdr form))) + (if (null? clauses) + (syntax-error "no clauses" form) + (process-clause (car clauses) (cdr clauses))))))) + + (define-expander 'DO + (lambda (form rename compare) + compare ;ignore + (if (syntax-match? '((* (IDENTIFIER EXPRESSION ? EXPRESSION)) + (+ EXPRESSION) + * FORM) + (cdr form)) + (let ((bindings (cadr form))) + `(,(rename 'LETREC) + ((,(rename 'DO-LOOP) + (,(rename 'LAMBDA) + ,(map car bindings) + (,(rename 'IF) ,(caaddr form) + ,(if (null? (cdaddr form)) + (unspecific-expression) + `(,(rename 'BEGIN) ,@(cdaddr form))) + (,(rename 'BEGIN) + ,@(cdddr form) + (,(rename 'DO-LOOP) + ,@(map (lambda (binding) + (if (null? (cddr binding)) + (car binding) + (caddr binding))) + bindings))))))) + (,(rename 'DO-LOOP) ,@(map cadr bindings)))) + (ill-formed-syntax form)))) + + (define-expander 'QUASIQUOTE + (lambda (form rename compare) + (define (descend-quasiquote x level return) + (cond ((pair? x) (descend-quasiquote-pair x level return)) + ((vector? x) (descend-quasiquote-vector x level return)) + (else (return 'QUOTE x)))) + (define (descend-quasiquote-pair x level return) + (cond ((not (and (pair? x) + (identifier? (car x)) + (pair? (cdr x)) + (null? (cddr x)))) + (descend-quasiquote-pair* x level return)) + ((compare (rename 'QUASIQUOTE) (car x)) + (descend-quasiquote-pair* x (+ level 1) return)) + ((compare (rename 'UNQUOTE) (car x)) + (if (zero? level) + (return 'UNQUOTE (cadr x)) + (descend-quasiquote-pair* x (- level 1) return))) + ((compare (rename 'UNQUOTE-SPLICING) (car x)) + (if (zero? level) + (return 'UNQUOTE-SPLICING (cadr x)) + (descend-quasiquote-pair* x (- level 1) return))) + (else + (descend-quasiquote-pair* x level return)))) + (define (descend-quasiquote-pair* x level return) + (descend-quasiquote + (car x) level + (lambda (car-mode car-arg) + (descend-quasiquote + (cdr x) level + (lambda (cdr-mode cdr-arg) + (cond ((and (eq? car-mode 'QUOTE) (eq? cdr-mode 'QUOTE)) + (return 'QUOTE x)) + ((eq? car-mode 'UNQUOTE-SPLICING) + (if (and (eq? cdr-mode 'QUOTE) (null? cdr-arg)) + (return 'UNQUOTE car-arg) + (return 'APPEND + (list car-arg + (finalize-quasiquote cdr-mode + cdr-arg))))) + ((and (eq? cdr-mode 'QUOTE) (list? cdr-arg)) + (return 'LIST + (cons (finalize-quasiquote car-mode car-arg) + (map (lambda (element) + (finalize-quasiquote 'QUOTE + element)) + cdr-arg)))) + ((eq? cdr-mode 'LIST) + (return 'LIST + (cons (finalize-quasiquote car-mode car-arg) + cdr-arg))) + (else + (return + 'CONS + (list (finalize-quasiquote car-mode car-arg) + (finalize-quasiquote cdr-mode cdr-arg)))))))))) + (define (descend-quasiquote-vector x level return) + (descend-quasiquote + (vector->list x) level + (lambda (mode arg) + (case mode + ((QUOTE) (return 'QUOTE x)) + ((LIST) (return 'VECTOR arg)) + (else + (return 'LIST->VECTOR + (list (finalize-quasiquote mode arg)))))))) + (define (finalize-quasiquote mode arg) + (case mode + ((QUOTE) `(,(rename 'QUOTE) ,arg)) + ((UNQUOTE) arg) + ((UNQUOTE-SPLICING) (syntax-error ",@ in illegal context" arg)) + (else `(,(rename mode) ,@arg)))) + (if (syntax-match? '(EXPRESSION) (cdr form)) + (descend-quasiquote (cadr form) 0 finalize-quasiquote) + (ill-formed-syntax form)))) + +;;; end MAKE-CORE-EXPANDER-MACROLOGY + ))) diff --git a/randinex.scm b/randinex.scm new file mode 100644 index 0000000..1c2b702 --- /dev/null +++ b/randinex.scm @@ -0,0 +1,99 @@ +;;;"randinex.scm" Pseudo-Random inexact real numbers for scheme. +;;; Copyright (C) 1991, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;This file is loaded by random.scm if inexact numbers are supported by +;the implementation. + +;;; Fixed sphere and normal functions from: Harald Hanche-Olsen + +(define random:float-radix + (+ 1 (exact->inexact random:MASK))) + +;;; This determines how many chunks will be neccessary to completely +;;; fill up an inexact real. +(define (random:size-float l x) + (cond ((= 1.0 (+ 1 x)) l) + ((= 4 l) l) + (else (random:size-float (+ l 1) (/ x random:float-radix))))) +(define random:chunks/float (random:size-float 0 1.0)) + +(define (random:uniform-chunk n state) + (if (= 1 n) + (/ (exact->inexact (random:chunk state)) + random:float-radix) + (/ (+ (random:uniform-chunk (- n 1) state) + (exact->inexact (random:chunk state))) + random:float-radix))) + +;;; Generate an inexact real between 0 and 1. +(define (random:uniform state) + (random:uniform-chunk random:chunks/float state)) + +;;; If x and y are independent standard normal variables, then with +;;; x=r*cos(t), y=r*sin(t), we find that t is uniformly distributed +;;; over [0,2*pi] and the cumulative distribution of r is +;;; 1-exp(-r^2/2). This latter means that u=exp(-r^2/2) is uniformly +;;; distributed on [0,1], so r=sqrt(-2 log u) can be used to generate r. + +(define (random:normal-vector! vect . args) + (let ((state (if (null? args) *random-state* (car args))) + (sum2 0)) + (let ((do! (lambda (k x) + (vector-set! vect k x) + (set! sum2 (+ sum2 (* x x)))))) + (do ((n (- (vector-length vect) 1) (- n 2))) + ((negative? n) sum2) + (let ((t (* 6.28318530717958 (random:uniform state))) + (r (sqrt (* -2 (log (random:uniform state)))))) + (do! n (* r (cos t))) + (if (positive? n) (do! (- n 1) (* r (sin t))))))))) + +(define random:normal + (let ((vect (make-vector 1))) + (lambda args + (apply random:normal-vector! vect args) + (vector-ref vect 0)))) + +;;; For the uniform distibution on the hollow sphere, pick a normal +;;; family and scale. + +(define (random:hollow-sphere! vect . args) + (let ((ms (sqrt (apply random:normal-vector! vect args)))) + (do ((n (- (vector-length vect) 1) (- n 1))) + ((negative? n)) + (vector-set! vect n (/ (vector-ref vect n) ms))))) + +;;; For the uniform distribution on the solid sphere, note that in +;;; this distribution the length r of the vector has cumulative +;;; distribution r^n; i.e., u=r^n is uniform [0,1], so r kan be +;;; generated as r=u^(1/n). + +(define (random:solid-sphere! vect . args) + (apply random:hollow-sphere! vect args) + (let ((r (expt (random:uniform (if (null? args) *random-state* (car args))) + (/ (vector-length vect))))) + (do ((n (- (vector-length vect) 1) (- n 1))) + ((negative? n)) + (vector-set! vect n (* r (vector-ref vect n)))))) + +(define (random:exp . args) + (let ((state (if (null? args) *random-state* (car args)))) + (- (log (random:uniform state))))) + +(require 'random) diff --git a/random.scm b/random.scm new file mode 100644 index 0000000..4f5a11d --- /dev/null +++ b/random.scm @@ -0,0 +1,101 @@ +;;;; "random.scm" Pseudo-Random number generator for scheme. +;;; Copyright (C) 1991, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'logical) + +(define random:tap 24) +(define random:size 55) + +(define (random:size-int l) + (let ((trial (string->number (make-string l #\f) 16))) + (if (and (exact? trial) (>= most-positive-fixnum trial)) + l + (random:size-int (- l 1))))) +(define random:chunk-size (* 4 (random:size-int 8))) + +(define random:MASK + (string->number (make-string (quotient random:chunk-size 4) #\f) 16)) + +(define *random-state* + '#( + "d909ef3e" "fd330ab3" "e33f7843" "76783fbd" "f3675fb3" + "b54ef879" "0be45590" "a6794679" "0bcd56d3" "fabcdef8" + "9cbd3efd" "3fd3efcd" "e064ef27" "dddecc08" "34444292" + "85444454" "4c519210" "c0366273" "54734567" "70abcddc" + "1bbdac53" "616c5a86" "a982efa9" "105996a0" "5f0cccba" + "1ea055e1" "fe2acd8d" "1891c1d4" "e6690270" "6912bccc" + "2678e141" "61222224" "907abcbb" "4ad6829b" "9cdd1404" + "57798841" "5b892496" "871c9cd1" "d1e67bda" "8b0a3233" + "578ef23f" "28274ef6" "823ef5ef" "845678c5" "e67890a5" + "5890abcb" "851fa9ab" "13efa13a" "b12278d6" "daf805ab" + "a0befc36" "0068a7b5" "e024fd90" "a7b690e2" "27f3571a" + 0)) + +(let ((random-strings *random-state*)) + (set! *random-state* (make-vector (+ random:size 1) 0)) + (let ((nibbles (quotient random:chunk-size 4))) + (do ((i 0 (+ i 1))) + ((= i random:size)) + (vector-set! + *random-state* i + (string->number (substring (vector-ref random-strings i) + 0 nibbles) + 16))))) + +;;; random:chunk returns an integer in the range of +;;; 0 to (- (expt 2 random:chunk-size) 1) +(define (random:chunk v) + (let* ((p (vector-ref v random:size)) + (ans (logical:logxor + (vector-ref v (modulo (- p random:tap) random:size)) + (vector-ref v p)))) + (vector-set! v p ans) + (vector-set! v random:size (modulo (- p 1) random:size)) + ans)) + +(define (random:random modu . args) + (let ((state (if (null? args) *random-state* (car args)))) + (if (exact? modu) + (do ((ilen 0 (+ 1 ilen)) + (s random:MASK + (+ random:MASK (* (+ 1 random:MASK) s)))) + ((>= s (- modu 1)) + (let ((slop (modulo (+ s (- 1 modu)) modu))) + (let loop ((n ilen) + (r (random:chunk state))) + (cond ((not (zero? n)) + (loop (+ -1 n) + (+ (* r (+ 1 random:MASK)) + (random:chunk state)))) + ((>= r slop) (modulo r modu)) + (else (loop ilen (random:chunk state)))))))) + + (* (random:uniform state) modu)))) +;;;random:uniform is in randinex.scm. It is needed only if inexact is +;;;supported. + +(define (random:make-random-state . args) + (let ((state (if (null? args) *random-state* (car args)))) + (list->vector (vector->list state)))) + +(define random random:random) +(define make-random-state random:make-random-state) + +(provide 'random) ;to prevent loops +(if (provided? 'inexact) (require 'random-inexact)) diff --git a/ratize.scm b/ratize.scm new file mode 100644 index 0000000..d8cad11 --- /dev/null +++ b/ratize.scm @@ -0,0 +1,13 @@ +;;;; "ratize.scm" Convert number to rational number + +(define (rational:simplest x y) + (define (sr x y) (let ((fx (floor x)) (fy (floor y))) + (cond ((not (< fx x)) fx) + ((= fx fy) (+ fx (/ (sr (/ (- y fy)) (/ (- x fx)))))) + (else (+ 1 fx))))) + (cond ((< y x) (rational:simplest y x)) + ((not (< x y)) (if (rational? x) x (slib:error))) + ((positive? x) (sr x y)) + ((negative? y) (- (sr (- y) (- x)))) + (else (if (and (exact? x) (exact? y)) 0 0.0)))) +(define (rationalize x e) (rational:simplest (- x e) (+ x e))) diff --git a/rdms.scm b/rdms.scm new file mode 100644 index 0000000..0fd4a2c --- /dev/null +++ b/rdms.scm @@ -0,0 +1,598 @@ +;;; "rdms.scm" rewrite 6 - the saga continues +; Copyright 1994 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define rdms:catalog-name '*catalog-data*) +(define rdms:domains-name '*domains-data*) +(define rdms:columns-name '*columns*) + +(define catalog:init-cols + '((1 #t table-name #f atom) + (2 #f column-limit #f uint) + (3 #f coltab-name #f atom) + (4 #f bastab-id #f base-id) + (5 #f user-integrity-rule #f expression) + (6 #f view-procedure #f expression))) + +(define catalog:column-limit-pos 2) +(define catalog:coltab-name-pos 3) +(define catalog:bastab-id-pos 4) +(define catalog:integrity-rule-pos 5) +(define catalog:view-proc-pos 6) + +(define columns:init-cols + '((1 #t column-number #f uint) + (2 #f primary-key? #f boolean) + (3 #f column-name #f symbol) + (4 #f column-integrity-rule #f expression) + (5 #f domain-name #f domain))) + +(define columns:primary?-pos 2) +(define columns:name-pos 3) +(define columns:integrity-rule-pos 4) +(define columns:domain-name-pos 5) + +(define domains:init-cols + '((1 #t domain-name #f atom) + (2 #f foreign-table #f atom) + (3 #f domain-integrity-rule #f expression) + (4 #f type-id #f type) + (5 #f type-param #f expression))) + +(define domains:foreign-pos 2) +(define domains:integrity-rule-pos 3) +(define domains:type-id-pos 4) +(define domains:type-param-pos 5) + +(define domains:init-data + `((atom #f + (lambda (x) (or (not x) (symbol? x) (number? x))) + atom + #f) + (type #f + #f ;type checked when openning + symbol + #f) + (base-id #f + (lambda (x) (or (symbol? x) (number? x))) + base-id + #f) + (uint #f + (lambda (x) + (and (number? x) + (integer? x) + (not (negative? x)))) + integer + #f) + (expression #f #f expression #f) + (boolean #f boolean? boolean #f) + (symbol #f symbol? symbol #f) + (string #f string? string #f) + (domain ,rdms:domains-name #f atom #f))) + +(define (rdms:warn identifier msg obj) + (display identifier) (display #\ ) (display msg) (write obj) (newline)) +(define rdms:error slib:error) + +(define (make-relational-system base) + (define basic + (lambda (name) + (let ((meth (base name))) + (cond ((not meth) (rdms:error 'make-relational-system + "essential method missing for:" name))) + meth))) + + (define (desc-row-type row) + (let ((domain (assq (car (cddddr row)) domains:init-data))) + (and domain (cadddr domain)))) + + (let ((make-base (base 'make-base)) + (open-base (basic 'open-base)) + (write-base (base 'write-base)) + (sync-base (base 'sync-base)) + (close-base (basic 'close-base)) + (base:supported-type? (basic 'supported-type?)) + (base:supported-key-type? (basic 'supported-key-type?)) + (base:make-table (base 'make-table)) + (base:open-table (basic 'open-table)) + (base:kill-table (base 'kill-table)) + (present? (basic 'present?)) + (base:ordered-for-each-key (basic 'ordered-for-each-key)) + (base:for-each-primary-key (basic 'for-each-key)) + (base:map-primary-key (basic 'map-key)) + (base:catalog-id (basic 'catalog-id)) + (cat:keyify-1 ((basic 'make-keyifier-1) + (desc-row-type (assv 1 catalog:init-cols)))) + (itypes + (lambda (rows) + (map (lambda (row) + (let ((domrow (assq (car (cddddr row)) domains:init-data))) + (cond (domrow (cadddr domrow)) + (else (rdms:error 'itypes "type not found for:" + (car (cddddr row))))))) + rows)))) + + (define (init-tab lldb id descriptor rows) + (let ((han (base:open-table lldb id 1 (itypes descriptor))) + (keyify-1 + ((base 'make-keyifier-1) (desc-row-type (assv 1 descriptor)))) + (putter ((basic 'make-putter) 1 (itypes descriptor)))) + (for-each (lambda (row) (putter han (keyify-1 (car row)) (cdr row))) + rows))) + + (define cat:get-row + (let ((cat:getter ((basic 'make-getter) 1 (itypes catalog:init-cols)))) + (lambda (bastab key) + (cat:getter bastab (cat:keyify-1 key))))) + + (define dom:get-row + (let ((dom:getter ((basic 'make-getter) 1 (itypes domains:init-cols))) + (dom:keyify-1 ((basic 'make-keyifier-1) + (desc-row-type (assv 1 domains:init-cols))))) + (lambda (bastab key) + (dom:getter bastab (dom:keyify-1 key))))) + + (define des:get-row + (let ((des:getter ((basic 'make-getter) 1 (itypes columns:init-cols))) + (des:keyify-1 ((basic 'make-keyifier-1) + (desc-row-type (assv 1 columns:init-cols))))) + (lambda (bastab key) + (des:getter bastab (des:keyify-1 key))))) + + (define (create-database filename) + (cond ((and filename (file-exists? filename)) + (rdms:warn 'create-database "file exists:" filename))) + (let* ((lldb (make-base filename 1 (itypes catalog:init-cols))) + (cattab (and lldb (base:open-table lldb base:catalog-id 1 + (itypes catalog:init-cols))))) + (cond + ((not lldb) (rdms:error 'make-base "failed.") #f) + ((not cattab) (rdms:error 'make-base "catalog missing.") + (close-base lldb) + #f) + (else + (let ((desdes-id (base:make-table lldb 1 (itypes columns:init-cols))) + (domdes-id (base:make-table lldb 1 (itypes columns:init-cols))) + (catdes-id (base:make-table lldb 1 (itypes columns:init-cols))) + (domtab-id (base:make-table lldb 1 (itypes domains:init-cols))) + ) + (cond + ((not (and catdes-id domdes-id domtab-id desdes-id)) + (rdms:error 'create-database "make-table failed.") + (close-base lldb) + #f) + (else + (init-tab lldb desdes-id columns:init-cols columns:init-cols) + (init-tab lldb domdes-id columns:init-cols domains:init-cols) + (init-tab lldb catdes-id columns:init-cols catalog:init-cols) + (init-tab lldb domtab-id domains:init-cols domains:init-data) + (init-tab + lldb base:catalog-id catalog:init-cols + `((*catalog-desc* 5 ,rdms:columns-name ,catdes-id #f #f) + (*domains-desc* 5 ,rdms:columns-name ,domdes-id #f #f) + (,rdms:catalog-name 6 *catalog-desc* ,base:catalog-id #f #f) + (,rdms:domains-name 5 *domains-desc* ,domtab-id #f #f) + (,rdms:columns-name 5 ,rdms:columns-name ,desdes-id #f #f))) + (init-database + filename #t lldb cattab + (base:open-table lldb domtab-id 1 (itypes domains:init-cols)) + #f)))))))) + + (define (base:catalog->domains lldb base:catalog) + (let ((cat:row (cat:get-row base:catalog rdms:domains-name))) + (and cat:row + (base:open-table lldb + (list-ref cat:row (+ -2 catalog:bastab-id-pos)) + 1 (itypes domains:init-cols))))) + + (define (open-database filename mutable) + (let* ((lldb (open-base filename mutable)) + (base:catalog + (and lldb (base:open-table lldb base:catalog-id + 1 (itypes catalog:init-cols)))) + (base:domains + (and base:catalog (base:catalog->domains lldb base:catalog)))) + (cond + ((not lldb) #f) + ((not base:domains) (close-base lldb) #f) + (else (init-database + filename mutable lldb base:catalog base:domains #f))))) + + (define (init-database rdms:filename mutable lldb + base:catalog base:domains rdms:catalog) + + (define (write-database filename) + (write-base lldb filename) + (set! rdms:filename filename)) + + (define (close-database) + (close-base lldb) + (set! rdms:filename #f) + (set! base:catalog #f) + (set! base:domains #f) + (set! rdms:catalog #f)) + + (define row-ref (lambda (row pos) (list-ref row (+ -2 pos)))) + (define row-eval (lambda (row pos) + (let ((ans (list-ref row (+ -2 pos)))) + (and ans (slib:eval ans))))) + + (define (open-table table-name writable) + (define cat:row (cat:get-row base:catalog table-name)) + (cond ((and writable (not mutable)) + (rdms:error "can't open-table for writing:" table-name))) + (let ((column-limit (row-ref cat:row catalog:column-limit-pos)) + (desc-table + (base:open-table + lldb + (row-ref (cat:get-row + base:catalog + (row-ref cat:row catalog:coltab-name-pos)) + catalog:bastab-id-pos) + 1 (itypes columns:init-cols))) + (base-table #f) + (base:get #f) + (primary-limit 1) + (column-name-alist '()) + (column-foreign-list '()) + (column-domain-list '()) + (column-type-list '()) + (export-alist '()) + (cirs '()) + (dirs '()) + (list->key #f) + (key->list #f)) + + (if (not desc-table) + (rdms:error "descriptor table doesn't exist for:" table-name)) + (do ((ci column-limit (+ -1 ci))) + ((zero? ci)) + (let* ((des:row (des:get-row desc-table ci)) + (column-name (row-ref des:row columns:name-pos)) + (column-domain (row-ref des:row columns:domain-name-pos))) + (set! cirs + (cons (row-eval des:row columns:integrity-rule-pos) cirs)) + (set! column-name-alist + (cons (cons column-name ci) column-name-alist)) + (cond + (column-domain + (let ((dom:row (dom:get-row base:domains column-domain))) + (set! dirs + (cons (row-eval dom:row domains:integrity-rule-pos) + dirs)) + (set! column-type-list + (cons (row-ref dom:row domains:type-id-pos) + column-type-list)) + (set! column-domain-list + (cons column-domain column-domain-list)) + (set! column-foreign-list + (cons + (let ((foreign-name + (row-ref dom:row domains:foreign-pos))) + (cond + ((or (not foreign-name) + (eq? foreign-name table-name)) #f) + (else + (let* ((tab (open-table foreign-name #f)) + (p? (and tab (tab 'get 1)))) + (cond + ((not tab) + (rdms:error "foreign key table missing for:" + foreign-name)) + ((not (= (tab 'primary-limit) 1)) + (rdms:error "foreign key table wrong type:" + foreign-name)) + (else p?)))))) + column-foreign-list)))) + (else + (rdms:error "missing domain for column:" ci column-name))) + (cond + ((row-ref des:row columns:primary?-pos) + (set! primary-limit (max primary-limit ci)) + (cond + ((base:supported-key-type? (car column-type-list))) + (else (rdms:error "key type not supported by base tables:" + (car column-type-list))))) + ((base:supported-type? (car column-type-list))) + (else (rdms:error "type not supported by base tables:" + (car column-type-list)))))) + (set! base-table + (base:open-table lldb (row-ref cat:row catalog:bastab-id-pos) + primary-limit column-type-list)) + (set! base:get ((basic 'make-getter) primary-limit column-type-list)) + (set! list->key + ((basic 'make-list-keyifier) primary-limit column-type-list)) + (set! key->list + ((basic 'make-key->list) primary-limit column-type-list)) + (let ((export-method + (lambda (name proc) + (set! export-alist + (cons (cons name proc) export-alist)))) + (generalize-to-table + (lambda (operation) + (lambda () + (base:for-each-primary-key base-table operation)))) + (accumulate-over-table + (lambda (operation) + (lambda () (base:map-primary-key base-table operation)))) + (ckey:retrieve ;ckey gets whole row (assumes exists) + (if (= primary-limit column-limit) key->list + (lambda (ckey) (append (key->list ckey) + (base:get base-table ckey)))))) + (export-method + 'row:retrieve + (if (= primary-limit column-limit) + (lambda keys + (let ((ckey (list->key keys))) + (and (present? base-table ckey) keys))) + (lambda keys + (let ((vals (base:get base-table (list->key keys)))) + (and vals (append keys vals)))))) + (export-method 'row:retrieve* + (accumulate-over-table + (if (= primary-limit column-limit) key->list + ckey:retrieve))) + (export-method + 'for-each-row + (let ((r (if (= primary-limit column-limit) key->list + ckey:retrieve))) + (lambda (proc) (base:ordered-for-each-key + base-table (lambda (ckey) (proc (r ckey))))))) + (cond + ((and mutable writable) + (letrec + ((combine-primary-keys + (cond + ((and (= primary-limit column-limit) + (> primary-limit 0)) + list->key) + ((eq? list->key car) list->key) + (else + (case primary-limit + ((1) (let ((keyify-1 ((base 'make-keyifier-1) + (car column-type-list)))) + (lambda (row) (keyify-1 (car row))))) + ((2) (lambda (row) + (list->key (list (car row) (cadr row))))) + ((3) (lambda (row) + (list->key (list (car row) (cadr row) + (caddr row))))) + ((4) (lambda (row) + (list->key + (list (car row) (cadr row) + (caddr row) (cadddr row))))) + (else (rdms:error 'combine-primary-keys + "bad number of primary keys" + primary-limit)))))) + (uir (row-eval cat:row catalog:integrity-rule-pos)) + (check-rules + (lambda (row) + (if (= column-limit (length row)) #t + (rdms:error "bad row length:" row)) + (for-each + (lambda (cir dir value column-name column-domain + foreign) + (cond + ((and dir (not (dir value))) + (rdms:error "violated domain integrity rule:" + table-name column-name + column-domain value)) + ((and cir (not (cir value))) + (rdms:error "violated column integrity rule:" + table-name column-name value)) + ((and foreign (not (foreign value))) + (rdms:error "foreign key missing:" + table-name column-name value)))) + cirs dirs row column-name-alist column-domain-list + column-foreign-list) + (cond ((and uir (not (uir row))) + (rdms:error "violated user integrity rule:" + row))))) + (putter + ((basic 'make-putter) primary-limit column-type-list)) + (row:insert + (lambda (row) + (check-rules row) + (let ((ckey (combine-primary-keys row))) + (if (present? base-table ckey) + (rdms:error 'row:insert "row present:" row)) + (putter base-table ckey + (list-tail row primary-limit))))) + (row:update + (lambda (row) + (check-rules row) + (putter base-table (combine-primary-keys row) + (list-tail row primary-limit))))) + + (export-method 'row:insert row:insert) + (export-method 'row:insert* + (lambda (rows) (for-each row:insert rows))) + (export-method 'row:update row:update) + (export-method 'row:update* + (lambda (rows) (for-each row:update rows)))) + + (letrec ((base:delete (basic 'delete)) + (ckey:remove (lambda (ckey) + (let ((r (ckey:retrieve ckey))) + (and r (base:delete base-table ckey)) + r)))) + (export-method 'row:remove + (lambda keys + (let ((ckey (list->key keys))) + (and (present? base-table ckey) + (ckey:remove ckey))))) + (export-method 'row:delete + (lambda keys + (base:delete base-table (list->key keys)))) + (export-method 'row:remove* + (accumulate-over-table ckey:remove)) + (export-method 'row:delete* + (generalize-to-table + (lambda (ckey) (base:delete base-table ckey)))) + (export-method 'close-table + (lambda () (set! base-table #f) + (set! desc-table #f) + (set! export-alist #f)))))) + + (export-method 'column-names (map car column-name-alist)) + (export-method 'column-foreigns column-foreign-list) + (export-method 'column-domains column-domain-list) + (export-method 'column-types column-type-list) + (export-method 'primary-limit primary-limit) + + (let ((translate-column + (lambda (column) + ;;(print 'translate-column column column-name-alist) + (let ((colp (assq column column-name-alist))) + (cond (colp (cdr colp)) + ((and (number? column) + (integer? column) + (<= 1 column column-limit)) + column) + (else (rdms:error "column not in table:" + column table-name))))))) + (lambda args + (cond + ((null? args) #f) + ((null? (cdr args)) + (let ((pp (assq (car args) export-alist))) + (and pp (cdr pp)))) + ((not (null? (cddr args))) + (rdms:error "too many arguments to methods:" args)) + (else + (let ((ci (translate-column (cadr args)))) + (cond + ((<= ci primary-limit) ;primary-key? + (let ((key-extractor + ((base 'make-key-extractor) + primary-limit column-type-list ci))) + (case (car args) + ((get) (lambda keys + (and (present? base-table (list->key keys)) + (list-ref keys (+ -1 ci))))) + ((get*) (lambda () + (base:map-primary-key + base-table + (lambda (ckey) (key-extractor ckey))))) + (else #f)))) + (else + (let ((index (- ci (+ 1 primary-limit)))) + (case (car args) + ((get) (lambda keys + (let ((row (base:get base-table + (list->key keys)))) + (and row (list-ref row index))))) + ((get*) (lambda () + (base:map-primary-key + base-table + (lambda (ckey) + (list-ref (base:get base-table ckey) + index))))) + (else #f))))))))))))) + + (define create-table + (and + mutable + (lambda (table-name . desc) + (if (not rdms:catalog) + (set! rdms:catalog (open-table rdms:catalog-name #t)) #f) + (cond + ((table-exists? table-name) + (rdms:error "table already exists:" table-name) #f) + ((null? desc) + (let ((colt-id + (base:make-table lldb 1 (itypes columns:init-cols)))) + ((rdms:catalog 'row:insert) + (list table-name + (length columns:init-cols) + ((rdms:catalog 'get 'coltab-name) + rdms:columns-name) + colt-id + #f + #f))) + (open-table table-name #t)) + ((null? (cdr desc)) + (set! desc (car desc)) + (let ((colt-id ((rdms:catalog 'get 'bastab-id) desc))) + (cond + (colt-id + (let ((coltable (open-table desc #f)) + (types '()) + (prilimit 0) + (colimit 0) + (colerr #f)) + (for-each (lambda (n p d) + (if (number? n) (set! colimit (max colimit n)) + (set! colerr #t)) + (if p (set! prilimit (+ 1 prilimit)) #f) + (set! types + (cons (dom:get-row base:domains d) + types))) + ((coltable 'get* 'column-number)) + ((coltable 'get* 'primary-key?)) + ((coltable 'get* 'domain-name))) + (cond (colerr (rdms:error "some column lacks a number.") #f) + ((or (< prilimit 1) + (and (> prilimit 4) + (not (= prilimit colimit)))) + (rdms:error "unreasonable number of primary keys:" + prilimit)) + (else + ((rdms:catalog 'row:insert) + (list table-name colimit desc + (base:make-table lldb prilimit types) #f #f)) + (open-table table-name #t))))) + (else + (rdms:error "table descriptor not found for:" desc) #f)))) + (else (rdms:error 'create-table "too many args:" + (cons table-name desc)) + #f))))) + + (define (table-exists? table-name) + (present? base:catalog (cat:keyify-1 table-name))) + + (define delete-table + (and mutable + (lambda (table-name) + (if (not rdms:catalog) + (set! rdms:catalog (open-table rdms:catalog-name #t)) #f) + (let ((table (open-table table-name #t)) + (row ((rdms:catalog 'row:remove) table-name))) + (and row (base:kill-table + lldb + (list-ref row (+ -1 catalog:bastab-id-pos)) + (table 'primary-limit) + (table 'column-type-list)) + row))))) + + (lambda (operation-name) + (case operation-name + ((close-database) close-database) + ((write-database) write-database) + ((open-table) open-table) + ((delete-table) delete-table) + ((create-table) create-table) + ((table-exists?) table-exists?) + (else #f))) + ) + (lambda (operation-name) + (case operation-name + ((create-database) create-database) + ((open-database) open-database) + (else #f))) + )) diff --git a/recobj.scm b/recobj.scm new file mode 100644 index 0000000..caf55a6 --- /dev/null +++ b/recobj.scm @@ -0,0 +1,54 @@ +;;; "recobj.scm" Records implemented as objects. +;;;From: whumeniu@datap.ca (Wade Humeniuk) + +(require 'object) + +(define record-type-name (make-generic-method)) +(define record-accessor (make-generic-method)) +(define record-modifier (make-generic-method)) +(define record? (make-generic-predicate)) +(define record-constructor (make-generic-method)) + +(define (make-record-type type-name field-names) + (define self (make-object)) + + (make-method! self record-type-name + (lambda (self) + type-name)) + (make-method! self record-accessor + (lambda (self field-name) + (let ((index (comlist:position field-name field-names))) + (if (not index) + (slib:error "record-accessor: invalid field-name argument." + field-name)) + (lambda (obj) + (record-accessor obj index))))) + + (make-method! self record-modifier + (lambda (self field) + (let ((index (comlist:position field field-names))) + (if (not index) + (slib:error "record-accessor: invalid field-name argument." + field-name)) + (lambda (obj newval) + (record-modifier obj index newval))))) + + (make-method! self record? (lambda (self) #t)) + + (make-method! self record-constructor + (lambda (class . field-values) + (let ((values (apply vector field-values))) + (define self (make-object)) + (make-method! self record-accessor + (lambda (self index) + (vector-ref values index))) + (make-method! self record-modifier + (lambda (self index newval) + (vector-set! values index newval))) + (make-method! self record-type-name + (lambda (self) (record-type-name class))) + self))) + self) + +(provide 'record-object) +(provide 'record) \ No newline at end of file diff --git a/record.scm b/record.scm new file mode 100644 index 0000000..555d3ea --- /dev/null +++ b/record.scm @@ -0,0 +1,211 @@ +; "record.scm" record data types +; Written by David Carlton, carlton@husc.harvard.edu. +; Re-Written by Aubrey Jaffer, jaffer@ai.mit.edu +; +; This code is in the public domain. + +; Implements `record' data structures for Scheme. Using only the +; opacity of procedures, makes record datatypes and +; record-type-descriptors disjoint from R4RS types and each other, and +; prevents forgery and corruption (modification without using +; RECORD-MODIFIER) of records. + +(require 'common-list-functions) + +(define vector? vector?) +(define vector-ref vector-ref) +(define vector-set! vector-set!) +(define vector-fill! vector-fill!) +(define vector->list vector->list) + +(define record-modifier #f) +(define record-accessor #f) +(define record-constructor #f) +(define record-predicate #f) +(define make-record-type #f) + +(let (;; Need to close these to keep magic-cookie hidden. + (make-vector make-vector) + (vector vector) + + ;; We have to wrap these to keep magic-cookie hidden. + (vect? vector?) + (vect-ref vector-ref) + (vect->list vector->list) + + ;; Need to wrap these to protect record data from being corrupted. + (vect-set! vector-set!) + (vect-fill! vector-fill!) + + (nvt "of non-vector type") + ) + (letrec + (;; Tag to identify rtd's. (A record is identified by the rtd + ;; that begins it.) + (magic-cookie (cons 'rtd '())) + (rtd? (lambda (object) + (and (vect? object) + (not (= (vector-length object) 0)) + (eq? (rtd-tag object) magic-cookie)))) + (rec? (lambda (obj) + (and (vect? obj) + (>= (vector-length obj) 1) + (or (eq? magic-cookie (rec-rtd obj)) + (rtd? (rec-rtd obj)))))) + + (vec:error + (lambda (proc-name msg obj) + (slib:error proc-name msg + (cond ((rtd? obj) 'rtd) + ((rec? obj) (rtd-name (rec-rtd obj))) + (else obj))))) + + ;; Internal accessor functions. No error checking. + (rtd-tag (lambda (x) (vect-ref x 0))) + (rtd-name (lambda (rtd) (vect-ref rtd 1))) + (rtd-fields (lambda (rtd) (vect-ref rtd 3))) + ;; rtd-vfields is padded out to the length of the vector, which is 1 + ;; more than the number of fields + (rtd-vfields (lambda (rtd) (cons #f (rtd-fields rtd)))) + ;; rtd-length is the length of the vector. + (rtd-length (lambda (rtd) (vect-ref rtd 4))) + + (rec-rtd (lambda (x) (vect-ref x 0))) + + (make-rec-type + (lambda (type-name field-names) + (if (not (string? type-name)) + (slib:error 'make-record-type "non-string type-name argument." + type-name)) + (if (or (and (list? field-names) (comlist:has-duplicates? field-names)) + (comlist:notevery symbol? field-names)) + (slib:error 'make-record-type "illegal field-names argument." + field-names)) + (let* ((augmented-length (+ 1 (length field-names))) + (rtd (vector magic-cookie + type-name + '() + field-names + augmented-length + #f + #f))) + (vect-set! rtd 5 + (lambda (x) + (and (vect? x) + (= (vector-length x) augmented-length) + (eq? (rec-rtd x) rtd)))) + (vect-set! rtd 6 + (lambda (x) + (and (vect? x) + (>= (vector-length x) augmented-length) + (eq? (rec-rtd x) rtd) + #t))) + rtd))) + + (rec-predicate + (lambda (rtd) + (if (not (rtd? rtd)) + (slib:error 'record-predicate "invalid argument." rtd)) + (vect-ref rtd 5))) + + (rec-constructor + (lambda (rtd . field-names) + (if (not (rtd? rtd)) + (slib:error 'record-constructor "illegal rtd argument." rtd)) + (if (or (null? field-names) + (equal? field-names (rtd-fields rtd))) + (let ((rec-length (- (rtd-length rtd) 1))) + (lambda elts + (if (= (length elts) rec-length) #t + (slib:error 'record-constructor + (rtd-name rtd) + "wrong number of arguments.")) + (apply vector rtd elts))) + (let ((rec-vfields (rtd-vfields rtd)) + (corrected-rec-length (rtd-length rtd)) + (field-names (car field-names))) + (if (or (and (list? field-names) (comlist:has-duplicates? field-names)) + (comlist:notevery (lambda (x) (memq x rec-vfields)) + field-names)) + (slib:error + 'record-constructor "invalid field-names argument." + (cdr rec-vfields))) + (let ((field-length (length field-names)) + (offsets + (map (lambda (field) (comlist:position field rec-vfields)) + field-names))) + (lambda elts + (if (= (length elts) field-length) #t + (slib:error 'record-constructor + (rtd-name rtd) + "wrong number of arguments.")) + (let ((result (make-vector corrected-rec-length))) + (vect-set! result 0 rtd) + (for-each (lambda (offset elt) + (vect-set! result offset elt)) + offsets + elts) + result))))))) + + (rec-accessor + (lambda (rtd field-name) + (if (not (rtd? rtd)) + (slib:error 'record-accessor "invalid rtd argument." rtd)) + (let ((index (comlist:position field-name (rtd-vfields rtd))) + (augmented-length (rtd-length rtd))) + (if (not index) + (slib:error 'record-accessor "invalid field-name argument." + field-name)) + (lambda (x) + (if (and (vect? x) + (>= (vector-length x) augmented-length) + (eq? rtd (rec-rtd x))) + #t + (slib:error 'record-accessor "wrong record type." x "not" rtd)) + (vect-ref x index))))) + + (rec-modifier + (lambda (rtd field-name) + (if (not (rtd? rtd)) + (slib:error 'record-modifier "invalid rtd argument." rtd)) + (let ((index (comlist:position field-name (rtd-vfields rtd))) + (augmented-length (rtd-length rtd))) + (if (not index) + (slib:error 'record-modifier "invalid field-name argument." + field-name)) + (lambda (x y) + (if (and (vect? x) + (>= (vector-length x) augmented-length) + (eq? rtd (rec-rtd x))) + #t + (slib:error 'record-modifier "wrong record type." x "not" rtd)) + (vect-set! x index y))))) + ) + + (set! vector? (lambda (obj) (and (not (rec? obj)) (vector? obj)))) + (set! vector-ref + (lambda (vector k) + (cond ((rec? vector) + (vec:error 'vector-ref nvt vector)) + (else (vect-ref vector k))))) + (set! vector->list + (lambda (vector k) + (cond ((rec? vector) + (vec:error 'vector->list nvt vector)) + (else (vect->list vector k))))) + (set! vector-set! + (lambda (vector k obj) + (cond ((rec? vector) + (vec:error 'vector-set! nvt vector)) + (else (vect-set! vector k obj))))) + (set! vector-fill! + (lambda (vector fill) + (cond ((rec? vector) + (vec:error 'vector-fill! nvt vector)) + (else (vect-fill! vector fill))))) + (set! record-modifier rec-modifier) + (set! record-accessor rec-accessor) + (set! record-constructor rec-constructor) + (set! record-predicate rec-predicate) + (set! make-record-type make-rec-type) + )) diff --git a/repl.scm b/repl.scm new file mode 100644 index 0000000..f51f493 --- /dev/null +++ b/repl.scm @@ -0,0 +1,92 @@ +; "repl.scm", read-eval-print-loop for Scheme +; Copyright (c) 1993, Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'dynamic-wind) +(define (repl:quit) (slib:error "not in repl:repl")) + +(define (repl:top-level repl:eval) + (repl:repl (lambda () (display "> ") + (force-output (current-output-port)) + (read)) + repl:eval + (lambda objs + (cond ((null? objs)) + (else + (write (car objs)) + (for-each (lambda (obj) + (display " ;") (newline) (write obj)) + (cdr objs)))) + (newline)))) + +(define (repl:repl repl:read repl:eval repl:print) + (let* ((old-quit repl:quit) + (old-error slib:error) + (old-eval slib:eval) + (old-load load) + (repl:load (lambda () + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (repl:eval o)) + (set! *load-pathname* old-load-pathname)))))) + (repl:restart #f) + (values? (provided? 'values)) + (has-char-ready? (provided? 'char-ready?)) + (repl:error (lambda args (require 'debug) (apply qpn args) + (repl:restart #f)))) + (dynamic-wind + (lambda () + (set! load repl:load) + (set! slib:eval repl:eval) + (set! slib:error repl:error) + (set! repl:quit + (lambda () (let ((cont repl:restart)) + (set! repl:restart #f) + (cont #t))))) + (lambda () + (do () ((call-with-current-continuation + (lambda (cont) + (set! repl:restart cont) + (do ((obj (repl:read) (repl:read))) + ((eof-object? obj) (repl:quit)) + (cond + (has-char-ready? + (let loop () + (cond ((char-ready?) + (let ((c (peek-char))) + (cond + ((eof-object? c)) + ((char=? #\newline c) (read-char)) + ((char-whitespace? c) + (read-char) (loop)) + (else (newline))))))))) + (if values? + (call-with-values (lambda () (repl:eval obj)) + repl:print) + (repl:print (repl:eval obj))))))))) + (lambda () (cond (repl:restart + (display ">>ERROR<<") (newline) + (repl:restart #f))) + (set! load old-load) + (set! slib:eval old-eval) + (set! slib:error old-error) + (set! repl:quit old-quit))))) diff --git a/report.scm b/report.scm new file mode 100644 index 0000000..64f4d46 --- /dev/null +++ b/report.scm @@ -0,0 +1,116 @@ +;;; "report.scm" relational-database-utility +; Copyright 1995 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;;; Considerations for report generation: +; * columnar vs. fixed-multi-line vs. variable-multi-line +; * overflow lines within column boundaries. +; * break overflow across page? +; * Page headers and footers (need to know current/previous record-number +; and next record-number). +; * Force page break on general expression (needs next row as arg). +; * Hierachical reports. + +;================================================================ + +(require 'format) +(require 'database-utilities) + +(define (dbutil:database arg) + (cond ((procedure? arg) arg) + ((string? arg) (dbutil:open-database arg)) + ((symbol? arg) (slib:eval arg)) + (else (slib:error "can't coerce to database: " arg)))) + +(define (dbutil:table arg) + (cond ((procedure? arg) arg) + ((and (list? arg) (= 2 (length arg))) + (((dbutil:database (car arg)) 'open-table) (cadr arg) #f)))) + +(define (dbutil:print-report table header reporter footer . args) + (define output-port (and (pair? args) (car args))) + (define page-height (and (pair? args) (pair? (cdr args)) (cadr args))) + (define minimum-break + (and (pair? args) (pair? (cdr args)) (pair? (cddr args)) (caddr args))) + (set! table (dbutil:table table)) + ((lambda (fun) + (cond ((output-port? output-port) + (fun output-port)) + ((string? output-port) + (call-with-output-file output-port fun)) + ((or (boolean? output-port) (null? output-port)) + (fun (current-output-port))) + (else (slib:error "can't coerce to output-port: " arg)))) + (lambda (output-port) + (set! page-height (or page-height (output-port-height output-port))) + (set! minimum-break (or minimum-break 0)) + (let ((output-page 0) + (output-line 0) + (nth-newline-index + (lambda (str n) + (define len (string-length str)) + (do ((i 0 (+ i 1))) + ((or (zero? n) (> i len)) (+ -1 i)) + (cond ((char=? #\newline (string-ref str i)) + (set! n (+ -1 n))))))) + (count-newlines + (lambda (str) + (define cnt 0) + (do ((i (+ -1 (string-length str)) (+ -1 i))) + ((negative? i) cnt) + (cond ((char=? #\newline (string-ref str i)) + (set! cnt (+ 1 cnt))))))) + (format (let ((oformat format)) + (lambda (dest fmt arg) + (cond ((not (procedure? fmt)) (oformat dest fmt arg)) + ((output-port? dest) (fmt dest arg)) + ((eq? #t dest) (fmt (current-output-port) arg)) + ((eq? #f dest) (call-with-output-string + (lambda (port) (fmt port arg)))) + (else (oformat dest fmt arg))))))) + (define column-names (table 'column-names)) + (define (do-header) + (let ((str (format #f header column-names))) + (display str output-port) + (set! output-line (count-newlines str)))) + (define (do-lines str inc) + (cond + ((< (+ output-line inc) page-height) + (display str output-port) + (set! output-line (+ output-line inc))) + (else ;outputting footer + (cond ((and (not (zero? minimum-break)) + (> cnt (* 2 minimum-break)) + (> (- page-height output-line) minimum-break)) + (let ((break (nth-newline-index + str (- page-height output-line)))) + (display (substring str 0 (+ 1 break) output-port)) + (set! str (substring str (+ 1 break) (string-length str))) + (set! inc (- inc (- page-height output-line)))))) + (format output-port footer column-names) + (display slib:form-feed output-port) + (set! output-page (+ 1 output-page)) + (do-header) + (do-lines str inc)))) + + (do-header) + ((table 'for-each-row) + (lambda (row) + (let ((str (format #f reporter row))) + (do-lines str (count-newlines str))))) + output-page)))) diff --git a/require.scm b/require.scm new file mode 100644 index 0000000..d1ebe9a --- /dev/null +++ b/require.scm @@ -0,0 +1,348 @@ +;;;; Implementation of VICINITY and MODULES for Scheme +;Copyright (C) 1991, 1992, 1993, 1994 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define *SLIB-VERSION* "2a6") + +;;; Standardize msdos -> ms-dos. +(define software-type + (cond ((eq? 'msdos (software-type)) + (lambda () 'ms-dos)) + (else software-type))) + +(define (user-vicinity) + (case (software-type) + ((VMS) "[.]") + (else ""))) + +(define program-vicinity + (let ((*vicinity-suffix* + (case (software-type) + ((AMIGA) '(#\: #\/)) + ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) + ((MACOS THINKC) '(#\:)) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT) '(#\/)) + ((VMS) '(#\: #\]))))) + (lambda () + (let loop ((i (- (string-length *load-pathname*) 1))) + (cond ((negative? i) "") + ((memv (string-ref *load-pathname* i) *vicinity-suffix*) + (substring *load-pathname* 0 (+ i 1))) + (else (loop (- i 1)))))))) + +(define sub-vicinity + (case (software-type) + ((VMS) + (lambda + (vic name) + (let ((l (string-length vic))) + (if (or (zero? (string-length vic)) + (not (char=? #\] (string-ref vic (- l 1))))) + (string-append vic "[" name "]") + (string-append (substring vic 0 (- l 1)) + "." name "]"))))) + (else + (let ((*vicinity-suffix* + (case (software-type) + ((NOSVE) ".") + ((UNIX COHERENT AMIGA) "/") + ((MACOS THINKC) ":") + ((MS-DOS WINDOWS ATARIST OS/2) "\\")))) + (lambda (vic name) + (string-append vic name *vicinity-suffix*)))))) + +(define (make-vicinity ) ) + +(define *catalog* + (map + (lambda (p) + (if (symbol? (cdr p)) p + (cons + (car p) + (if (pair? (cdr p)) + (cons + (cadr p) + (in-vicinity (library-vicinity) (cddr p))) + (in-vicinity (library-vicinity) (cdr p)))))) + '( + (rev4-optional-procedures . "sc4opt") + (rev2-procedures . "sc2") + (multiarg/and- . "mularg") + (multiarg-apply . "mulapply") + (rationalize . "ratize") + (transcript . "trnscrpt") + (with-file . "withfile") + (dynamic-wind . "dynwind") + (dynamic . "dynamic") + (fluid-let macro . "fluidlet") + (alist . "alist") + (hash . "hash") + (sierpinski . "sierpinski") + (soundex . "soundex") + (hash-table . "hashtab") + (logical . "logical") + (random . "random") + (random-inexact . "randinex") + (modular . "modular") + (primes . "primes") + (factor . "factor") + (charplot . "charplot") + (sort . "sort") + (tsort . topological-sort) + (topological-sort . "tsort") + (common-list-functions . "comlist") + (tree . "tree") + (format . "format") + (format-inexact . "formatfl") + (generic-write . "genwrite") + (pretty-print . "pp") + (pprint-file . "ppfile") + (object->string . "obj2str") + (string-case . "strcase") + (stdio . "stdio") + (printf . "printf") + (scanf . "scanf") + (line-i/o . "lineio") + (string-port . "strport") + (getopt . "getopt") + (debug . "debug") + (qp . "qp") + (break defmacro . "break") + (trace defmacro . "trace") +; (eval . "eval") + (record . "record") + (promise . "promise") + (synchk . "synchk") + (defmacroexpand . "defmacex") + (macro-by-example defmacro . "mbe") + (syntax-case . "scainit") + (syntactic-closures . "scmacro") + (macros-that-work . "macwork") + (macro . macros-that-work) + (object . "object") + (record-object . "recobj") + (yasos macro . "yasyn") + (oop . yasos) + (collect macro . "collect") + (struct defmacro . "struct") + (structure syntax-case . "structure") + (values . "values") + (queue . "queue") + (priority-queue . "priorque") + (array . "array") + (array-for-each . "arraymap") + (repl . "repl") + (process . "process") + (chapter-order . "chap") + (posix-time . "time") + (common-lisp-time . "cltime") + (relational-database . "rdms") + (database-utilities . "dbutil") + (database-browse . "dbrowse") + (alist-table . "alistab") + (parameters . "paramlst") + (read-command . "comparse") + (batch . "batch") + (make-crc . "makcrc") + (wt-tree . "wttree") + (string-search . "strsrch") + (root . "root") + ))) + +(set! *catalog* + (append (list + (cons 'schelog + (in-vicinity (sub-vicinity (library-vicinity) "schelog") + "schelog")) + (cons 'portable-scheme-debugger + (in-vicinity (sub-vicinity (library-vicinity) "psd") + "psd-slib"))) + *catalog*)) + +(define *load-pathname* #f) + +(define (slib:pathnameize-load *old-load*) + (lambda ( . extra) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (apply *old-load* (cons extra)) + (require:provide ) + (set! *load-pathname* old-load-pathname)))) + +(set! slib:load-source + (slib:pathnameize-load slib:load-source)) +(set! slib:load + (slib:pathnameize-load slib:load)) + +;;;; MODULES + +(define *modules* '()) + +(define (require:provided? feature) + (if (symbol? feature) + (if (memq feature *features*) #t + (let ((path (cdr (or (assq feature *catalog*) '(#f . #f))))) + (cond ((symbol? path) (provided? path)) + ((member (if (pair? path) (cdr path) path) *modules*) + #t) + (else #f)))) + (and (member feature *modules*) #t))) + +(define (require:feature->path feature) + (if (symbol? feature) + (let ((path (cdr (or (assq feature *catalog*) '(#f . #f))))) + (if (symbol? path) (require:feature->path path) path)) + feature)) + +(define (require:require feature) + (or (require:provided? feature) + (let ((path (require:feature->path feature))) + (cond ((and (not path) (string? feature) (file-exists? feature)) + (set! path feature))) + (cond ((not path) + ;;(newline) (display ";required feature not supported: ") + ;;(display feature) (newline) + (slib:error ";required feature not supported: " feature)) + ((not (pair? path)) ;simple name + (slib:load path) + (require:provide feature)) + (else ;special loads + (require (car path)) + (apply (case (car path) + ((macro) macro:load) + ((syntactic-closures) synclo:load) + ((syntax-case) syncase:load) + ((macros-that-work) macwork:load) + ((macro-by-example) defmacro:load) + ((defmacro) defmacro:load) + ((source) slib:load-source) + ((compiled) slib:load-compiled)) + (if (list? path) (cdr path) (list (cdr path)))) + (require:provide feature)))))) + +(define (require:provide feature) + (if (symbol? feature) + (if (not (memq feature *features*)) + (set! *features* (cons feature *features*))) + (if (not (member feature *modules*)) + (set! *modules* (cons feature *modules*))))) + +(require:provide 'vicinity) + +(define provide require:provide) +(define provided? require:provided?) +(define require require:require) + +;;; Supported by all implementations +(provide 'eval) +(provide 'defmacro) + +(if (and (string->number "0.0") (inexact? (string->number "0.0"))) + (provide 'inexact)) +(if (rational? (string->number "1/19")) (provide 'rational)) +(if (real? (string->number "0.0")) (provide 'real)) +(if (complex? (string->number "1+i")) (provide 'complex)) +(let ((n (string->number "9999999999999999999999999999999"))) + (if (and n (exact? n)) (provide 'bignum))) + +(define current-time + (if (provided? 'current-time) current-time + (let ((c 0)) + (lambda () (set! c (+ c 1)) c)))) +(define difftime (if (provided? 'current-time) difftime -)) +(define offset-time (if (provided? 'current-time) offset-time +)) + +(define report:print + (lambda args + (for-each (lambda (x) (write x) (display #\ )) args) + (newline))) + +(define slib:report + (let ((slib:report (lambda () (slib:report-version) (slib:report-locations)))) + (lambda args + (cond ((null? args) (slib:report)) + ((not (string? (car args))) + (slib:report-version) (slib:report-locations #t)) + ((require:provided? 'transcript) + (transcript-on (car args)) + (slib:report) + (transcript-off)) + ((require:provided? 'with-file) + (with-output-to-file (car args) slib:report)) + (else (slib:report)))))) + +(define slib:report-version + (lambda () + (report:print + 'SLIB *SLIB-VERSION* 'on (scheme-implementation-type) + (scheme-implementation-version) 'on (software-type)))) + +(define slib:report-locations + (let ((features *features*) (catalog *catalog*)) + (lambda args + (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity)) + (report:print '(LIBRARY-VICINITY) 'is (library-vicinity)) + (report:print '(SCHEME-FILE-SUFFIX) 'is (scheme-file-suffix)) + (cond (*load-pathname* + (report:print '*LOAD-PATHNAME* 'is *load-pathname*))) + (cond ((not (null? *modules*)) + (report:print 'Loaded '*MODULES* 'are: *modules*))) + (let* ((i (+ -1 5))) + (cond ((eq? (car features) (car *features*))) + (else (report:print 'loaded '*FEATURES* ':) (display slib:tab))) + (for-each + (lambda (x) + (cond ((eq? (car features) x) + (if (not (eq? (car features) (car *features*))) (newline)) + (report:print 'Implementation '*FEATURES* ':) + (display slib:tab) (set! i (+ -1 5))) + ((zero? i) (newline) (display slib:tab) (set! i (+ -1 5))) + ((not (= (+ -1 5) i)) (display #\ ))) + (write x) (set! i (+ -1 i))) + *features*)) + (newline) + (let* ((i #t)) + (cond ((not (eq? (car catalog) (car *catalog*))) + (report:print 'Additional '*CATALOG* ':))) + (cond ((or (pair? args) (not (eq? (car catalog) (car *catalog*)))) + (for-each + (lambda (x) + (cond ((eq? (car catalog) x) + (report:print 'Implementation '*CATALOG* ':) + (set! i (pair? args)) + (cond (i) + (else (display slib:tab) (report:print x) + (display slib:tab) (report:print '...))))) + (cond (i (display slib:tab) (report:print x)))) + *catalog*)) + (else (report:print 'Implementation '*CATALOG* ':) + (display slib:tab) (report:print (car *catalog*)) + (display slib:tab) (report:print '...)))) + (newline)))) + +(let ((sit (scheme-implementation-version))) + (cond ((zero? (string-length sit))) + ((or (not (string? sit)) (char=? #\? (string-ref sit 0))) + (newline) + (slib:report-version) + (report:print 'edit (scheme-implementation-type) ".init" + 'to 'set '(scheme-implementation-version) 'string) + (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity)) + (report:print 'type '(slib:report) 'for 'configuration) + (newline)))) diff --git a/root.scm b/root.scm new file mode 100644 index 0000000..5ba78c1 --- /dev/null +++ b/root.scm @@ -0,0 +1,149 @@ +;;;"root.scm" Newton's and Laguerre's methods for finding roots. +;Copyright (C) 1996 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;;; Newton's Method explained in: +;;; D. E. Knuth, "The Art of Computer Programming", Vol 2 / +;;; Seminumerical Algorithms, Reading Massachusetts, Addison-Wesley +;;; Publishing Company, 2nd Edition, p. 510 + +(define (newton:find-integer-root f df/dx x_0) + (let loop ((x x_0) (fx (f x_0))) + (cond + ((zero? fx) x) + (else + (let ((df (df/dx x))) + (cond + ((zero? df) #f) ; stuck at local min/max + (else + (let* ((delta (quotient (+ fx (quotient df 2)) df)) + (next-x (cond ((not (zero? delta)) (- x delta)) + ((positive? fx) (- x 1)) + (else (- x -1)))) + (next-fx (f next-x))) + (cond ((>= (abs next-fx) (abs fx)) x) + (else (loop next-x next-fx))))))))))) + +(define (integer-sqrt y) + (newton:find-integer-root (lambda (x) (- (* x x) y)) + (lambda (x) (* 2 x)) + (ash 1 (quotient (integer-length y) 2)))) + +(define (newton:find-root f df/dx x_0 prec) + (if (and (negative? prec) (integer? prec)) + (let loop ((x x_0) (fx (f x_0)) (count prec)) + (cond ((zero? count) x) + (else (let ((df (df/dx x))) + (cond ((zero? df) #f) ; stuck at local min/max + (else (let* ((next-x (- x (/ fx df))) + (next-fx (f next-x))) + (cond ((= next-x x) x) + ((> (abs next-fx) (abs fx)) #f) + (else (loop next-x next-fx + (+ 1 count))))))))))) + (let loop ((x x_0) (fx (f x_0))) + (cond ((< (abs fx) prec) x) + (else (let ((df (df/dx x))) + (cond ((zero? df) #f) ; stuck at local min/max + (else (let* ((next-x (- x (/ fx df))) + (next-fx (f next-x))) + (cond ((= next-x x) x) + ((> (abs next-fx) (abs fx)) #f) + (else (loop next-x next-fx)))))))))))) + +;;; H. J. Orchard, "The Laguerre Method for Finding the Zeros of +;;; Polynomials", IEEE Transactions on Circuits and Systems, Vol. 36, +;;; No. 11, November 1989, pp 1377-1381. + +(define (laguerre:find-root f df/dz ddf/dz^2 z_0 prec) + (if (and (negative? prec) (integer? prec)) + (let loop ((z z_0) (fz (f z_0)) (count prec)) + (cond ((zero? count) z) + (else + (let* ((df (df/dz z)) + (ddf (ddf/dz^2 z)) + (disc (sqrt (- (* df df) (* fz ddf))))) + (if (zero? disc) + #f + (let* ((next-z + (- z (/ fz (if (negative? (+ (* (real-part df) + (real-part disc)) + (* (imag-part df) + (imag-part disc)))) + (- disc) disc)))) + (next-fz (f next-z))) + (cond ((>= (magnitude next-fz) (magnitude fz)) z) + (else (loop next-z next-fz (+ 1 count)))))))))) + (let loop ((z z_0) (fz (f z_0)) (delta-z #f)) + (cond ((< (magnitude fz) prec) z) + (else + (let* ((df (df/dz z)) + (ddf (ddf/dz^2 z)) + (disc (sqrt (- (* df df) (* fz ddf))))) + (print 'disc disc) + (if (zero? disc) + #f + (let* ((next-z + (- z (/ fz (if (negative? (+ (* (real-part df) + (real-part disc)) + (* (imag-part df) + (imag-part disc)))) + (- disc) disc)))) + (next-delta-z (magnitude (- next-z z)))) + (print 'next-z next-z ) + (print '(f next-z) (f next-z)) + (print 'delta-z delta-z 'next-delta-z next-delta-z) + (cond ((zero? next-delta-z) z) + ((and delta-z (>= next-delta-z delta-z)) z) + (else + (loop next-z (f next-z) next-delta-z))))))))))) + +(define (laguerre:find-polynomial-root deg f df/dz ddf/dz^2 z_0 prec) + (if (and (negative? prec) (integer? prec)) + (let loop ((z z_0) (fz (f z_0)) (count prec)) + (cond ((zero? count) z) + (else + (let* ((df (df/dz z)) + (ddf (ddf/dz^2 z)) + (tmp (* (+ deg -1) df)) + (sqrt-H (sqrt (- (* tmp tmp) (* deg (+ deg -1) fz ddf)))) + (df+sqrt-H (+ df sqrt-H)) + (df-sqrt-H (- df sqrt-H)) + (next-z + (- z (/ (* deg fz) + (if (>= (magnitude df+sqrt-H) + (magnitude df-sqrt-H)) + df+sqrt-H + df-sqrt-H))))) + (loop next-z (f next-z) (+ 1 count)))))) + (let loop ((z z_0) (fz (f z_0))) + (cond ((< (magnitude fz) prec) z) + (else + (let* ((df (df/dz z)) + (ddf (ddf/dz^2 z)) + (tmp (* (+ deg -1) df)) + (sqrt-H (sqrt (- (* tmp tmp) (* deg (+ deg -1) fz ddf)))) + (df+sqrt-H (+ df sqrt-H)) + (df-sqrt-H (- df sqrt-H)) + (next-z + (- z (/ (* deg fz) + (if (>= (magnitude df+sqrt-H) + (magnitude df-sqrt-H)) + df+sqrt-H + df-sqrt-H))))) + (loop next-z (f next-z)))))))) diff --git a/sc2.scm b/sc2.scm new file mode 100644 index 0000000..5a10f84 --- /dev/null +++ b/sc2.scm @@ -0,0 +1,66 @@ +;"sc2.scm" Implementation of rev2 procedures eliminated in subsequent versions. +; Copyright (C) 1991, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define (substring-move-left! string1 start1 end1 string2 start2) + (do ((i start1 (+ i 1)) + (j start2 (+ j 1)) + (l (- end1 start1) (- l 1))) + ((<= l 0)) + (string-set! string2 j (string-ref string1 i)))) + +(define (substring-move-right! string1 start1 end1 string2 start2) + (do ((i (+ start1 (- end1 start1) -1) (- i 1)) + (j (+ start2 (- end1 start1) -1) (- j 1)) + (l (- end1 start1) (- l 1))) + ((<= l 0)) + (string-set! string2 j (string-ref string1 i)))) + +(define (substring-fill! string start end char) + (do ((i start (+ i 1)) + (l (- end start) (- l 1))) + ((<= l 0)) + (string-set! string i char))) + +(define (string-null? str) + (= 0 (string-length str))) + +(define append! + (lambda args + (cond ((null? args) '()) + ((null? (cdr args)) (car args)) + ((null? (car args)) (apply append! (cdr args))) + (else + (set-cdr! (last-pair (car args)) + (apply append! (cdr args))) + (car args))))) + +;;;; need to add code for OBJECT-HASH and OBJECT-UNHASH + +(define 1+ + (let ((+ +)) + (lambda (n) (+ n 1)))) +(define -1+ + (let ((+ +)) + (lambda (n) (+ n -1)))) + +(define ? >) +(define >=? >=) diff --git a/sc4opt.scm b/sc4opt.scm new file mode 100644 index 0000000..176d7f1 --- /dev/null +++ b/sc4opt.scm @@ -0,0 +1,53 @@ +;"sc4opt.scm" Implementation of optional Scheme^4 functions for IEEE Scheme +;Copyright (C) 1991, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; Some of these functions may be already defined in your Scheme. +;;; Comment out those definitions for functions which are already defined. + +;;; This code conforms to: William Clinger and Jonathan Rees, editors. +;;; Revised^4 Report on the Algorithmic Language Scheme. + +(define (list-tail l p) + (if (< p 1) l (list-tail (cdr l) (- p 1)))) + +(define (string->list s) + (do ((i (- (string-length s) 1) (- i 1)) + (l '() (cons (string-ref s i) l))) + ((< i 0) l))) + +(define (list->string l) (apply string l)) + +(define string-copy string-append) + +(define (string-fill! s obj) + (do ((i (- (string-length s) 1) (- i 1))) + ((< i 0)) + (string-set! s i obj))) + +(define (list->vector l) (apply vector l)) + +(define (vector->list s) + (do ((i (- (vector-length s) 1) (- i 1)) + (l '() (cons (vector-ref s i) l))) + ((< i 0) l))) + +(define (vector-fill! s obj) + (do ((i (- (vector-length s) 1) (- i 1))) + ((< i 0)) + (vector-set! s i obj))) diff --git a/sc4sc3.scm b/sc4sc3.scm new file mode 100644 index 0000000..a120c5d --- /dev/null +++ b/sc4sc3.scm @@ -0,0 +1,35 @@ +;"sc4sc3.scm" Implementation of rev4 procedures for rev3. +;Copyright (C) 1991 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;;; peek-char, number->string, and string->number need to be written here. + +;;; APPEND, +, *, -, /, =, <, >, <=, >=, MAP, and FOR-EACH need to +;;; accept more general number or arguments. + +(define (list? x) + (let loop ((fast x) (slow x)) + (or (null? fast) + (and (pair? fast) + (let ((fast (cdr fast))) + (or (null? fast) + (and (pair? fast) + (let ((fast (cdr fast)) + (slow (cdr slow))) + (and (not (eq? fast slow)) + (loop fast slow)))))))))) diff --git a/scaexpp.scm b/scaexpp.scm new file mode 100644 index 0000000..aa058a6 --- /dev/null +++ b/scaexpp.scm @@ -0,0 +1,2956 @@ +;;; "scaexpp.scm" syntax-case macros +;;; Copyright (C) 1992 R. Kent Dybvig +;;; +;;; Permission to copy this software, in whole or in part, to use this +;;; software for any lawful purpose, and to redistribute this software +;;; is granted subject to the restriction that all copies made of this +;;; software must include this copyright notice in full. This software +;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED, +;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY +;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE +;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY +;;; NATURE WHATSOEVER. + +;;; Written by Robert Hieb & Kent Dybvig + +;;; This file was munged by a simple minded sed script since it left +;;; its original authors' hands. See syncase.sh for the horrid details. + +(begin ((lambda () +(letrec ((lambda-var-list (lambda (vars) +((letrec ((lvl (lambda (vars ls) +(if (pair? vars) +(lvl (cdr vars) +(cons (car vars) +ls)) +(if (id? vars) +(cons vars +ls) +(if (null? +vars) +ls +(if (syntax-object? +vars) +(lvl (unwrap +vars) +ls) +(cons vars +ls)))))))) +lvl) +vars +'()))) +(gen-var (lambda (id) (gen-sym (id-sym-name id)))) +(gen-sym (lambda (sym) +(syncase:new-symbol-hook (symbol->string sym)))) +(strip (lambda (x) +(if (syntax-object? x) +(strip (syntax-object-expression x)) +(if (pair? x) +((lambda (a d) +(if (if (eq? a (car x)) +(eq? d (cdr x)) +#f) +x +(cons a d))) +(strip (car x)) +(strip (cdr x))) +(if (vector? x) +((lambda (old) +((lambda (new) +(if (syncase:andmap eq? old new) +x +(list->vector new))) +(map strip old))) +(vector->list x)) +x))))) +(regen (lambda (x) +((lambda (g000139) +(if (memv g000139 '(ref)) +(syncase:build-lexical-reference (cadr x)) +(if (memv g000139 '(primitive)) +(syncase:build-global-reference (cadr x)) +(if (memv g000139 '(id)) +(syncase:build-identifier (cadr x)) +(if (memv g000139 '(quote)) +(syncase:build-data (cadr x)) +(if (memv +g000139 +'(lambda)) +(syncase:build-lambda +(cadr x) +(regen (caddr x))) +(begin g000139 +(syncase:build-application +(syncase:build-global-reference +(car x)) +(map regen +(cdr x)))))))))) +(car x)))) +(gen-vector (lambda (x) +(if (eq? (car x) 'list) +(syncase:list* 'vector (cdr x)) +(if (eq? (car x) 'quote) +(list +'quote +(list->vector (cadr x))) +(list 'list->vector x))))) +(gen-append (lambda (x y) +(if (equal? y ''()) +x +(list 'append x y)))) +(gen-cons (lambda (x y) +(if (eq? (car y) 'list) +(syncase:list* 'list x (cdr y)) +(if (if (eq? (car x) 'quote) +(eq? (car y) 'quote) +#f) +(list +'quote +(cons (cadr x) (cadr y))) +(if (equal? y ''()) +(list 'list x) +(list 'cons x y)))))) +(gen-map (lambda (e map-env) +((lambda (formals actuals) +(if (eq? (car e) 'ref) +(car actuals) +(if (syncase:andmap +(lambda (x) +(if (eq? (car x) 'ref) +(memq (cadr x) +formals) +#f)) +(cdr e)) +(syncase:list* +'map +(list 'primitive (car e)) +(map ((lambda (r) +(lambda (x) +(cdr (assq (cadr x) +r)))) +(map cons +formals +actuals)) +(cdr e))) +(syncase:list* +'map +(list 'lambda formals e) +actuals)))) +(map cdr map-env) +(map (lambda (x) (list 'ref (car x))) +map-env)))) +(gen-ref (lambda (var level maps k) +(if (= level 0) +(k var maps) +(gen-ref +var +(- level 1) +(cdr maps) +(lambda (outer-var outer-maps) +((lambda (b) +(if b +(k (cdr b) maps) +((lambda (inner-var) +(k inner-var +(cons (cons (cons outer-var +inner-var) +(car maps)) +outer-maps))) +(gen-sym var)))) +(assq outer-var (car maps)))))))) +(chi-syntax (lambda (src exp r w) +((letrec ((gen (lambda (e maps k) +(if (id? e) +((lambda (n) +((lambda (b) +(if (eq? (binding-type +b) +'syntax) +((lambda (level) +(if (< (length +maps) +level) +(syntax-error +src +"missing ellipsis in") +(gen-ref +n +level +maps +(lambda (x +maps) +(k (list +'ref +x) +maps))))) +(binding-value +b)) +(if (ellipsis? +(wrap e +w)) +(syntax-error +src +"invalid context for ... in") +(k (list +'id +(wrap e +w)) +maps)))) +(lookup +n +e +r))) +(id-var-name +e +w)) +((lambda (g000141) +((lambda (g000142) +((lambda (g000140) +(if (not (eq? g000140 +'no)) +((lambda (_dots1 +_dots2) +(if (if (ellipsis? +(wrap _dots1 +w)) +(ellipsis? +(wrap _dots2 +w)) +#f) +(k (list +'id +(wrap _dots1 +w)) +maps) +(g000142))) +(car g000140) +(cadr g000140)) +(g000142))) +(syntax-dispatch +g000141 +'(pair (any) +pair +(any) +atom) +(vector)))) +(lambda () +((lambda (g000144) +((lambda (g000145) +((lambda (g000143) +(if (not (eq? g000143 +'no)) +((lambda (_x +_dots +_y) +(if (ellipsis? +(wrap _dots +w)) +(gen _y +maps +(lambda (y +maps) +(gen _x +(cons '() +maps) +(lambda (x +maps) +(if (null? +(car maps)) +(syntax-error +src +"extra ellipsis in") +(k (gen-append +(gen-map +x +(car maps)) +y) +(cdr maps))))))) +(g000145))) +(car g000143) +(cadr g000143) +(caddr +g000143)) +(g000145))) +(syntax-dispatch +g000144 +'(pair (any) +pair +(any) +any) +(vector)))) +(lambda () +((lambda (g000147) +((lambda (g000146) +(if (not (eq? g000146 +'no)) +((lambda (_x +_y) +(gen _x +maps +(lambda (x +maps) +(gen _y +maps +(lambda (y +maps) +(k (gen-cons +x +y) +maps)))))) +(car g000146) +(cadr g000146)) +((lambda (g000149) +((lambda (g000148) +(if (not (eq? g000148 +'no)) +((lambda (_e1 +_e2) +(gen (cons _e1 +_e2) +maps +(lambda (e +maps) +(k (gen-vector +e) +maps)))) +(car g000148) +(cadr g000148)) +((lambda (g000151) +((lambda (g000150) +(if (not (eq? g000150 +'no)) +((lambda (__) +(k (list +'quote +(wrap e +w)) +maps)) +(car g000150)) +(syntax-error +g000151))) +(syntax-dispatch +g000151 +'(any) +(vector)))) +g000149))) +(syntax-dispatch +g000149 +'(vector +pair +(any) +each +any) +(vector)))) +g000147))) +(syntax-dispatch +g000147 +'(pair (any) +any) +(vector)))) +g000144)))) +g000141)))) +e))))) +gen) +exp +'() +(lambda (e maps) (regen e))))) +(ellipsis? (lambda (x) +;; I dont know what this is supposed to do, and removing it seemed harmless. +;; (if (if (top-level-bound? 'dp) dp #f) +;; (break) +;; (syncase:void)) +(if (identifier? x) +(free-id=? x '...) +#f))) +(chi-syntax-definition (lambda (e w) +((lambda (g000153) +((lambda (g000154) +((lambda (g000152) +(if (not (eq? g000152 +'no)) +((lambda (__ +_name +_val) +(if (id? _name) +(list _name +_val) +(g000154))) +(car g000152) +(cadr g000152) +(caddr +g000152)) +(g000154))) +(syntax-dispatch +g000153 +'(pair (any) +pair +(any) +pair +(any) +atom) +(vector)))) +(lambda () +(syntax-error +g000153)))) +(wrap e w)))) +(chi-definition (lambda (e w) +((lambda (g000156) +((lambda (g000157) +((lambda (g000155) +(if (not (eq? g000155 +'no)) +(apply +(lambda (__ +_name +_args +_e1 +_e2) +(if (if (id? _name) +(valid-bound-ids? +(lambda-var-list +_args)) +#f) +(list _name +(cons '#(syntax-object +lambda +(top)) +(cons _args +(cons _e1 +_e2)))) +(g000157))) +g000155) +(g000157))) +(syntax-dispatch +g000156 +'(pair (any) +pair +(pair (any) any) +pair +(any) +each +any) +(vector)))) +(lambda () +((lambda (g000159) +((lambda (g000158) +(if (not (eq? g000158 +'no)) +((lambda (__ +_name +_val) +(list _name +_val)) +(car g000158) +(cadr g000158) +(caddr +g000158)) +((lambda (g000161) +((lambda (g000162) +((lambda (g000160) +(if (not (eq? g000160 +'no)) +((lambda (__ +_name) +(if (id? _name) +(list _name +(list '#(syntax-object +syncase:void +(top)))) +(g000162))) +(car g000160) +(cadr g000160)) +(g000162))) +(syntax-dispatch +g000161 +'(pair (any) +pair +(any) +atom) +(vector)))) +(lambda () +(syntax-error +g000161)))) +g000159))) +(syntax-dispatch +g000159 +'(pair (any) +pair +(any) +pair +(any) +atom) +(vector)))) +g000156)))) +(wrap e w)))) +(chi-sequence (lambda (e w) +((lambda (g000164) +((lambda (g000163) +(if (not (eq? g000163 'no)) +((lambda (__ _e) _e) +(car g000163) +(cadr g000163)) +(syntax-error g000164))) +(syntax-dispatch +g000164 +'(pair (any) each any) +(vector)))) +(wrap e w)))) +(chi-macro-def (lambda (def r w) +(syncase:eval-hook (chi def null-env w)))) +(chi-local-syntax (lambda (e r w) +((lambda (g000166) +((lambda (g000167) +((lambda (g000165) +(if (not (eq? g000165 +'no)) +(apply +(lambda (_who +_var +_val +_e1 +_e2) +(if (valid-bound-ids? +_var) +((lambda (new-vars) +((lambda (new-w) +(chi-body +(cons _e1 +_e2) +e +(extend-macro-env +new-vars +((lambda (w) +(map (lambda (x) +(chi-macro-def +x +r +w)) +_val)) +(if (free-id=? +_who +'#(syntax-object +letrec-syntax +(top))) +new-w +w)) +r) +new-w)) +(make-binding-wrap +_var +new-vars +w))) +(map gen-var +_var)) +(g000167))) +g000165) +(g000167))) +(syntax-dispatch +g000166 +'(pair (any) +pair +(each pair +(any) +pair +(any) +atom) +pair +(any) +each +any) +(vector)))) +(lambda () +((lambda (g000169) +((lambda (g000168) +(if (not (eq? g000168 +'no)) +((lambda (__) +(syntax-error +(wrap e +w))) +(car g000168)) +(syntax-error +g000169))) +(syntax-dispatch +g000169 +'(any) +(vector)))) +g000166)))) +e))) +(chi-body (lambda (body source r w) +(if (null? (cdr body)) +(chi (car body) r w) +((letrec ((parse1 (lambda (body +var-ids +var-vals +macro-ids +macro-vals) +(if (null? body) +(syntax-error +(wrap source +w) +"no expressions in body") +((letrec ((parse2 (lambda (e) +((lambda (b) +((lambda (g000170) +(if (memv +g000170 +'(macro)) +(parse2 +(chi-macro +(binding-value +b) +e +r +empty-wrap +(lambda (e +r +w) +(wrap e +w)))) +(if (memv +g000170 +'(definition)) +(parse1 +(cdr body) +(cons (cadr b) +var-ids) +(cons (caddr +b) +var-vals) +macro-ids +macro-vals) +(if (memv +g000170 +'(syntax-definition)) +(parse1 +(cdr body) +var-ids +var-vals +(cons (cadr b) +macro-ids) +(cons (caddr +b) +macro-vals)) +(if (memv +g000170 +'(sequence)) +(parse1 +(append +(cdr b) +(cdr body)) +var-ids +var-vals +macro-ids +macro-vals) +(begin g000170 +(if (valid-bound-ids? +(append +var-ids +macro-ids)) +((lambda (new-var-names +new-macro-names) +((lambda (w) +((lambda (r) +(syncase:build-letrec +new-var-names +(map (lambda (x) +(chi x +r +w)) +var-vals) +(syncase:build-sequence +(map (lambda (x) +(chi x +r +w)) +body)))) +(extend-macro-env +new-macro-names +(map (lambda (x) +(chi-macro-def +x +r +w)) +macro-vals) +(extend-var-env +new-var-names +r)))) +(make-binding-wrap +(append +macro-ids +var-ids) +(append +new-macro-names +new-var-names) +empty-wrap))) +(map gen-var +var-ids) +(map gen-var +macro-ids)) +(syntax-error +(wrap source +w) +"invalid identifier")))))))) +(car b))) +(syntax-type +e +r +empty-wrap))))) +parse2) +(car body)))))) +parse1) +(map (lambda (x) (wrap x w)) body) +'() +'() +'() +'())))) +(syntax-type (lambda (e r w) +(if (syntax-object? e) +(syntax-type +(syntax-object-expression e) +r +(join-wraps +(syntax-object-wrap e) +w)) +(if (if (pair? e) +(identifier? (car e)) +#f) +((lambda (n) +((lambda (b) +((lambda (g000171) +(if (memv +g000171 +'(special)) +(if (memv +n +'(define)) +(cons 'definition +(chi-definition +e +w)) +(if (memv +n +'(define-syntax)) +(cons 'syntax-definition +(chi-syntax-definition +e +w)) +(if (memv +n +'(begin)) +(cons 'sequence +(chi-sequence +e +w)) +(begin n +(syncase:void))))) +(begin g000171 +b))) +(binding-type b))) +(lookup n (car e) r))) +(id-var-name (car e) w)) +'(other))))) +(chi-args (lambda (args r w source source-w) +(if (pair? args) +(cons (chi (car args) r w) +(chi-args +(cdr args) +r +w +source +source-w)) +(if (null? args) +'() +(if (syntax-object? args) +(chi-args +(syntax-object-expression +args) +r +(join-wraps +w +(syntax-object-wrap +args)) +source +source-w) +(syntax-error +(wrap source source-w))))))) +(chi-ref (lambda (e name binding w) +((lambda (g000172) +(if (memv g000172 '(lexical)) +(syncase:build-lexical-reference name) +(if (memv +g000172 +'(global global-unbound)) +(syncase:build-global-reference name) +(begin g000172 +(id-error +(wrap e w)))))) +(binding-type binding)))) +(chi-macro (letrec ((check-macro-output (lambda (x) +(if (pair? +x) +(begin (check-macro-output +(car x)) +(check-macro-output +(cdr x))) +((lambda (g000173) +(if g000173 +g000173 +(if (vector? +x) +((lambda (n) +((letrec ((g000174 (lambda (i) +(if (= i +n) +(syncase:void) +(begin (check-macro-output +(vector-ref +x +i)) +(g000174 +(+ i +1))))))) +g000174) +0)) +(vector-length +x)) +(if (symbol? +x) +(syntax-error +x +"encountered raw symbol") +(syncase:void))))) +(syntax-object? +x)))))) +(lambda (p e r w k) +((lambda (mw) +((lambda (x) +(check-macro-output x) +(k x r mw)) +(p (wrap e (join-wraps mw w))))) +(new-mark-wrap))))) +(chi-pair (lambda (e r w k) +((lambda (first rest) +(if (id? first) +((lambda (n) +((lambda (b) +((lambda (g000175) +(if (memv +g000175 +'(core)) +((binding-value b) +e +r +w) +(if (memv +g000175 +'(macro)) +(chi-macro +(binding-value +b) +e +r +w +k) +(if (memv +g000175 +'(special)) +((binding-value +b) +e +r +w +k) +(begin g000175 +(syncase:build-application +(chi-ref +first +n +b +w) +(chi-args +rest +r +w +e +w))))))) +(binding-type b))) +(lookup n first r))) +(id-var-name first w)) +(syncase:build-application +(chi first r w) +(chi-args rest r w e w)))) +(car e) +(cdr e)))) +(chi (lambda (e r w) +(if (symbol? e) +((lambda (n) +(chi-ref e n (lookup n e r) w)) +(id-var-name e w)) +(if (pair? e) +(chi-pair e r w chi) +(if (syntax-object? e) +(chi (syntax-object-expression e) +r +(join-wraps +w +(syntax-object-wrap e))) +(if ((lambda (g000176) +(if g000176 +g000176 +((lambda (g000177) +(if g000177 +g000177 +((lambda (g000178) +(if g000178 +g000178 +(char? +e))) +(string? e)))) +(number? e)))) +(boolean? e)) +(syncase:build-data e) +(syntax-error (wrap e w)))))))) +(chi-top (lambda (e r w) +(if (pair? e) +(chi-pair e r w chi-top) +(if (syntax-object? e) +(chi-top +(syntax-object-expression e) +r +(join-wraps +w +(syntax-object-wrap e))) +(chi e r w))))) +(wrap (lambda (x w) +(if (null? w) +x +(if (syntax-object? x) +(make-syntax-object +(syntax-object-expression x) +(join-wraps +w +(syntax-object-wrap x))) +(if (null? x) +x +(make-syntax-object x w)))))) +(unwrap (lambda (x) +(if (syntax-object? x) +((lambda (e w) +(if (pair? e) +(cons (wrap (car e) w) +(wrap (cdr e) w)) +(if (vector? e) +(list->vector +(map (lambda (x) +(wrap x w)) +(vector->list e))) +e))) +(syntax-object-expression x) +(syntax-object-wrap x)) +x))) +(bound-id-member? (lambda (x list) +(if (not (null? list)) +((lambda (g000179) +(if g000179 +g000179 +(bound-id-member? +x +(cdr list)))) +(bound-id=? x (car list))) +#f))) +(valid-bound-ids? (lambda (ids) +(if ((letrec ((all-ids? (lambda (ids) +((lambda (g000181) +(if g000181 +g000181 +(if (id? (car ids)) +(all-ids? +(cdr ids)) +#f))) +(null? +ids))))) +all-ids?) +ids) +((letrec ((unique? (lambda (ids) +((lambda (g000180) +(if g000180 +g000180 +(if (not (bound-id-member? +(car ids) +(cdr ids))) +(unique? +(cdr ids)) +#f))) +(null? +ids))))) +unique?) +ids) +#f))) +(bound-id=? (lambda (i j) +(if (eq? (id-sym-name i) +(id-sym-name j)) +((lambda (i j) +(if (eq? (car i) (car j)) +(same-marks? +(cdr i) +(cdr j)) +#f)) +(id-var-name&marks i empty-wrap) +(id-var-name&marks j empty-wrap)) +#f))) +(free-id=? (lambda (i j) +(if (eq? (id-sym-name i) (id-sym-name j)) +(eq? (id-var-name i empty-wrap) +(id-var-name j empty-wrap)) +#f))) +(id-var-name&marks (lambda (id w) +(if (null? w) +(if (symbol? id) +(list id) +(id-var-name&marks +(syntax-object-expression +id) +(syntax-object-wrap +id))) +((lambda (n&m first) +(if (pair? first) +((lambda (n) +((letrec ((search (lambda (rib) +(if (null? +rib) +n&m +(if (if (eq? (caar rib) +n) +(same-marks? +(cdr n&m) +(cddar +rib)) +#f) +(cdar rib) +(search +(cdr rib))))))) +search) +first)) +(car n&m)) +(cons (car n&m) +(if ((lambda (g000182) +(if g000182 +g000182 +(not (eqv? first +(cadr n&m))))) +(null? +(cdr n&m))) +(cons first +(cdr n&m)) +(cddr n&m))))) +(id-var-name&marks +id +(cdr w)) +(car w))))) +(id-var-name (lambda (id w) +(if (null? w) +(if (symbol? id) +id +(id-var-name +(syntax-object-expression +id) +(syntax-object-wrap id))) +(if (pair? (car w)) +(car (id-var-name&marks id w)) +(id-var-name id (cdr w)))))) +(same-marks? (lambda (x y) +(if (null? x) +(null? y) +(if (not (null? y)) +(if (eqv? (car x) (car y)) +(same-marks? +(cdr x) +(cdr y)) +#f) +#f)))) +(join-wraps2 (lambda (w1 w2) +((lambda (x w1) +(if (null? w1) +(if (if (not (pair? x)) +(eqv? x (car w2)) +#f) +(cdr w2) +(cons x w2)) +(cons x (join-wraps2 w1 w2)))) +(car w1) +(cdr w1)))) +(join-wraps1 (lambda (w1 w2) +(if (null? w1) +w2 +(cons (car w1) +(join-wraps1 (cdr w1) w2))))) +(join-wraps (lambda (w1 w2) +(if (null? w2) +w1 +(if (null? w1) +w2 +(if (pair? (car w2)) +(join-wraps1 w1 w2) +(join-wraps2 w1 w2)))))) +(make-wrap-rib (lambda (ids new-names w) +(if (null? ids) +'() +(cons ((lambda (n&m) +(cons (car n&m) +(cons (car new-names) +(cdr n&m)))) +(id-var-name&marks +(car ids) +w)) +(make-wrap-rib +(cdr ids) +(cdr new-names) +w))))) +(make-binding-wrap (lambda (ids new-names w) +(if (null? ids) +w +(cons (make-wrap-rib +ids +new-names +w) +w)))) +(new-mark-wrap (lambda () +(set! current-mark +(+ current-mark 1)) +(list current-mark))) +(current-mark 0) +(top-wrap '(top)) +(empty-wrap '()) +(id-sym-name (lambda (x) +(if (symbol? x) +x +(syntax-object-expression x)))) +(id? (lambda (x) +((lambda (g000183) +(if g000183 +g000183 +(if (syntax-object? x) +(symbol? +(syntax-object-expression x)) +#f))) +(symbol? x)))) +(global-extend (lambda (type sym val) +(extend-global-env +sym +(cons type val)))) +(lookup (lambda (name id r) +(if (eq? name (id-sym-name id)) +(global-lookup name) +((letrec ((search (lambda (r name) +(if (null? r) +'(displaced-lexical) +(if (pair? +(car r)) +(if (eq? (caar r) +name) +(cdar r) +(search +(cdr r) +name)) +(if (eq? (car r) +name) +'(lexical) +(search +(cdr r) +name))))))) +search) +r +name)))) +(extend-syntax-env (lambda (vars vals r) +(if (null? vars) +r +(cons (cons (car vars) +(cons 'syntax +(car vals))) +(extend-syntax-env +(cdr vars) +(cdr vals) +r))))) +(extend-var-env append) +(extend-macro-env (lambda (vars vals r) +(if (null? vars) +r +(cons (cons (car vars) +(cons 'macro +(car vals))) +(extend-macro-env +(cdr vars) +(cdr vals) +r))))) +(null-env '()) +(global-lookup (lambda (sym) +((lambda (g000184) +(if g000184 +g000184 +'(global-unbound))) +(syncase:get-global-definition-hook sym)))) +(extend-global-env (lambda (sym binding) +(syncase:put-global-definition-hook +sym +binding))) +(binding-value cdr) +(binding-type car) +(arg-check (lambda (pred? x who) +(if (not (pred? x)) +(syncase:error-hook who "invalid argument" x) +(syncase:void)))) +(id-error (lambda (x) +(syntax-error +x +"invalid context for identifier"))) +(scope-error (lambda (id) +(syntax-error +id +"invalid context for bound identifier"))) +(syntax-object-wrap (lambda (x) (vector-ref x 2))) +(syntax-object-expression (lambda (x) (vector-ref x 1))) +(make-syntax-object (lambda (expression wrap) +(vector +'syntax-object +expression +wrap))) +(syntax-object? (lambda (x) +(if (vector? x) +(if (= (vector-length x) 3) +(eq? (vector-ref x 0) +'syntax-object) +#f) +#f)))) +(global-extend 'core 'letrec-syntax chi-local-syntax) +(global-extend 'core 'let-syntax chi-local-syntax) +(global-extend +'core +'quote +(lambda (e r w) +((lambda (g000136) +((lambda (g000135) +(if (not (eq? g000135 'no)) +((lambda (__ _e) (syncase:build-data (strip _e))) +(car g000135) +(cadr g000135)) +((lambda (g000138) +((lambda (g000137) +(if (not (eq? g000137 'no)) +((lambda (__) +(syntax-error (wrap e w))) +(car g000137)) +(syntax-error g000138))) +(syntax-dispatch +g000138 +'(any) +(vector)))) +g000136))) +(syntax-dispatch +g000136 +'(pair (any) pair (any) atom) +(vector)))) +e))) +(global-extend +'core +'syntax +(lambda (e r w) +((lambda (g000132) +((lambda (g000131) +(if (not (eq? g000131 'no)) +((lambda (__ _x) (chi-syntax e _x r w)) +(car g000131) +(cadr g000131)) +((lambda (g000134) +((lambda (g000133) +(if (not (eq? g000133 'no)) +((lambda (__) +(syntax-error (wrap e w))) +(car g000133)) +(syntax-error g000134))) +(syntax-dispatch +g000134 +'(any) +(vector)))) +g000132))) +(syntax-dispatch +g000132 +'(pair (any) pair (any) atom) +(vector)))) +e))) +(global-extend +'core +'syntax-lambda +(lambda (e r w) +((lambda (g000127) +((lambda (g000128) +((lambda (g000126) +(if (not (eq? g000126 'no)) +((lambda (__ _id _level _exp) +(if (if (valid-bound-ids? _id) +(map (lambda (x) +(if (integer? x) +(if (exact? x) +(not (negative? +x)) +#f) +#f)) +(map unwrap _level)) +#f) +((lambda (new-vars) +(syncase:build-lambda +new-vars +(chi _exp +(extend-syntax-env +new-vars +(map unwrap +_level) +r) +(make-binding-wrap +_id +new-vars +w)))) +(map gen-var _id)) +(g000128))) +(car g000126) +(cadr g000126) +(caddr g000126) +(cadddr g000126)) +(g000128))) +(syntax-dispatch +g000127 +'(pair (any) +pair +(each pair (any) pair (any) atom) +pair +(any) +atom) +(vector)))) +(lambda () +((lambda (g000130) +((lambda (g000129) +(if (not (eq? g000129 'no)) +((lambda (__) +(syntax-error (wrap e w))) +(car g000129)) +(syntax-error g000130))) +(syntax-dispatch +g000130 +'(any) +(vector)))) +g000127)))) +e))) +(global-extend +'core +'lambda +(lambda (e r w) +((lambda (g000121) +((lambda (g000120) +(if (not (eq? g000120 'no)) +((lambda (__ _id _e1 _e2) +(if (not (valid-bound-ids? _id)) +(syntax-error +(wrap e w) +"invalid parameter list") +((lambda (new-vars) +(syncase:build-lambda +new-vars +(chi-body +(cons _e1 _e2) +e +(extend-var-env +new-vars +r) +(make-binding-wrap +_id +new-vars +w)))) +(map gen-var _id)))) +(car g000120) +(cadr g000120) +(caddr g000120) +(cadddr g000120)) +((lambda (g000123) +((lambda (g000122) +(if (not (eq? g000122 'no)) +((lambda (__ _ids _e1 _e2) +((lambda (old-ids) +(if (not (valid-bound-ids? +(lambda-var-list +_ids))) +(syntax-error +(wrap e w) +"invalid parameter list") +((lambda (new-vars) +(syncase:build-improper-lambda +(reverse +(cdr new-vars)) +(car new-vars) +(chi-body +(cons _e1 +_e2) +e +(extend-var-env +new-vars +r) +(make-binding-wrap +old-ids +new-vars +w)))) +(map gen-var +old-ids)))) +(lambda-var-list _ids))) +(car g000122) +(cadr g000122) +(caddr g000122) +(cadddr g000122)) +((lambda (g000125) +((lambda (g000124) +(if (not (eq? g000124 +'no)) +((lambda (__) +(syntax-error +(wrap e w))) +(car g000124)) +(syntax-error +g000125))) +(syntax-dispatch +g000125 +'(any) +(vector)))) +g000123))) +(syntax-dispatch +g000123 +'(pair (any) +pair +(any) +pair +(any) +each +any) +(vector)))) +g000121))) +(syntax-dispatch +g000121 +'(pair (any) +pair +(each any) +pair +(any) +each +any) +(vector)))) +e))) +(global-extend +'core +'letrec +(lambda (e r w) +((lambda (g000116) +((lambda (g000117) +((lambda (g000115) +(if (not (eq? g000115 'no)) +(apply +(lambda (__ _id _val _e1 _e2) +(if (valid-bound-ids? _id) +((lambda (new-vars) +((lambda (w r) +(syncase:build-letrec +new-vars +(map (lambda (x) +(chi x +r +w)) +_val) +(chi-body +(cons _e1 _e2) +e +r +w))) +(make-binding-wrap +_id +new-vars +w) +(extend-var-env +new-vars +r))) +(map gen-var _id)) +(g000117))) +g000115) +(g000117))) +(syntax-dispatch +g000116 +'(pair (any) +pair +(each pair (any) pair (any) atom) +pair +(any) +each +any) +(vector)))) +(lambda () +((lambda (g000119) +((lambda (g000118) +(if (not (eq? g000118 'no)) +((lambda (__) +(syntax-error (wrap e w))) +(car g000118)) +(syntax-error g000119))) +(syntax-dispatch +g000119 +'(any) +(vector)))) +g000116)))) +e))) +(global-extend +'core +'if +(lambda (e r w) +((lambda (g000110) +((lambda (g000109) +(if (not (eq? g000109 'no)) +((lambda (__ _test _then) +(syncase:build-conditional +(chi _test r w) +(chi _then r w) +(chi (list '#(syntax-object +syncase:void +(top))) +r +empty-wrap))) +(car g000109) +(cadr g000109) +(caddr g000109)) +((lambda (g000112) +((lambda (g000111) +(if (not (eq? g000111 'no)) +((lambda (__ _test _then _else) +(syncase:build-conditional +(chi _test r w) +(chi _then r w) +(chi _else r w))) +(car g000111) +(cadr g000111) +(caddr g000111) +(cadddr g000111)) +((lambda (g000114) +((lambda (g000113) +(if (not (eq? g000113 +'no)) +((lambda (__) +(syntax-error +(wrap e w))) +(car g000113)) +(syntax-error +g000114))) +(syntax-dispatch +g000114 +'(any) +(vector)))) +g000112))) +(syntax-dispatch +g000112 +'(pair (any) +pair +(any) +pair +(any) +pair +(any) +atom) +(vector)))) +g000110))) +(syntax-dispatch +g000110 +'(pair (any) pair (any) pair (any) atom) +(vector)))) +e))) +(global-extend +'core +'set! +(lambda (e r w) +((lambda (g000104) +((lambda (g000105) +((lambda (g000103) +(if (not (eq? g000103 'no)) +((lambda (__ _id _val) +(if (id? _id) +((lambda (val n) +((lambda (g000108) +(if (memv +g000108 +'(lexical)) +(syncase:build-lexical-assignment +n +val) +(if (memv +g000108 +'(global +global-unbound)) +(syncase:build-global-assignment +n +val) +(begin g000108 +(id-error +(wrap _id +w)))))) +(binding-type +(lookup n _id r)))) +(chi _val r w) +(id-var-name _id w)) +(g000105))) +(car g000103) +(cadr g000103) +(caddr g000103)) +(g000105))) +(syntax-dispatch +g000104 +'(pair (any) pair (any) pair (any) atom) +(vector)))) +(lambda () +((lambda (g000107) +((lambda (g000106) +(if (not (eq? g000106 'no)) +((lambda (__) +(syntax-error (wrap e w))) +(car g000106)) +(syntax-error g000107))) +(syntax-dispatch +g000107 +'(any) +(vector)))) +g000104)))) +e))) +(global-extend +'special +'begin +(lambda (e r w k) +((lambda (body) +(if (null? body) +(if (eqv? k chi-top) +(chi (list '#(syntax-object syncase:void (top))) +r +empty-wrap) +(syntax-error +(wrap e w) +"no expressions in body of")) +(syncase:build-sequence +((letrec ((dobody (lambda (body) +(if (null? body) +'() +((lambda (first) +(cons first +(dobody +(cdr body)))) +(k (car body) +r +empty-wrap)))))) +dobody) +body)))) +(chi-sequence e w)))) +(global-extend +'special +'define +(lambda (e r w k) +(if (eqv? k chi-top) +((lambda (n&v) +((lambda (n) +(global-extend 'global n '()) +(syncase:build-global-definition +n +(chi (cadr n&v) r empty-wrap))) +(id-var-name (car n&v) empty-wrap))) +(chi-definition e w)) +(syntax-error +(wrap e w) +"invalid context for definition")))) +(global-extend +'special +'define-syntax +(lambda (e r w k) +(if (eqv? k chi-top) +((lambda (n&v) +(global-extend +'macro +(id-var-name (car n&v) empty-wrap) +(chi-macro-def (cadr n&v) r empty-wrap)) +(chi (list '#(syntax-object syncase:void (top))) +r +empty-wrap)) +(chi-syntax-definition e w)) +(syntax-error +(wrap e w) +"invalid context for definition")))) +(set! expand-syntax +(lambda (x) (chi-top x null-env top-wrap))) +(set! implicit-identifier +(lambda (id sym) +(arg-check id? id 'implicit-identifier) +(arg-check symbol? sym 'implicit-identifier) +(if (syntax-object? id) +(wrap sym (syntax-object-wrap id)) +sym))) +(set! syntax-object->datum (lambda (x) (strip x))) +(set! generate-temporaries +(lambda (ls) +(arg-check list? ls 'generate-temporaries) +(map (lambda (x) (wrap (syncase:new-symbol-hook "g") top-wrap)) ls))) +(set! free-identifier=? +(lambda (x y) +(arg-check id? x 'free-identifier=?) +(arg-check id? y 'free-identifier=?) +(free-id=? x y))) +(set! bound-identifier=? +(lambda (x y) +(arg-check id? x 'bound-identifier=?) +(arg-check id? y 'bound-identifier=?) +(bound-id=? x y))) +(set! identifier? (lambda (x) (id? x))) +(set! syntax-error +(lambda (object . messages) +(for-each +(lambda (x) (arg-check string? x 'syntax-error)) +messages) +((lambda (message) +(syncase:error-hook 'expand-syntax message (strip object))) +(if (null? messages) +"invalid syntax" +(apply string-append messages))))) +(set! syncase:install-global-transformer +(lambda (sym p) (global-extend 'macro sym p))) +((lambda () +(letrec ((match (lambda (e p k w r) +(if (eq? r 'no) +r +((lambda (g000100) +(if (memv g000100 '(any)) +(cons (wrap e w) r) +(if (memv +g000100 +'(free-id)) +(if (if (identifier? +e) +(free-id=? +(wrap e w) +(vector-ref +k +(cdr p))) +#f) +r +'no) +(begin g000100 +(if (syntax-object? +e) +(match* +(syntax-object-expression +e) +p +k +(join-wraps +w +(syntax-object-wrap +e)) +r) +(match* +e +p +k +w +r)))))) +(car p))))) +(match* (lambda (e p k w r) +((lambda (g000101) +(if (memv g000101 '(pair)) +(if (pair? e) +(match +(car e) +(cadr p) +k +w +(match +(cdr e) +(cddr p) +k +w +r)) +'no) +(if (memv g000101 '(each)) +(if (eq? (cadr p) 'any) +((lambda (l) +(if (eq? l 'no) +l +(cons l r))) +(match-each-any +e +w)) +(if (null? e) +(match-empty +(cdr p) +r) +((lambda (l) +(if (eq? l +'no) +l +((letrec ((collect (lambda (l) +(if (null? +(car l)) +r +(cons (map car +l) +(collect +(map cdr +l))))))) +collect) +l))) +(match-each +e +(cdr p) +k +w)))) +(if (memv +g000101 +'(atom)) +(if (equal? +(cdr p) +e) +r +'no) +(if (memv +g000101 +'(vector)) +(if (vector? e) +(match +(vector->list +e) +(cdr p) +k +w +r) +'no) +(begin g000101 +(syncase:void))))))) +(car p)))) +(match-empty (lambda (p r) +((lambda (g000102) +(if (memv g000102 '(any)) +(cons '() r) +(if (memv +g000102 +'(each)) +(match-empty +(cdr p) +r) +(if (memv +g000102 +'(pair)) +(match-empty +(cadr p) +(match-empty +(cddr p) +r)) +(if (memv +g000102 +'(free-id +atom)) +r +(if (memv +g000102 +'(vector)) +(match-empty +(cdr p) +r) +(begin g000102 +(syncase:void)))))))) +(car p)))) +(match-each-any (lambda (e w) +(if (pair? e) +((lambda (l) +(if (eq? l 'no) +l +(cons (wrap (car e) +w) +l))) +(match-each-any +(cdr e) +w)) +(if (null? e) +'() +(if (syntax-object? +e) +(match-each-any +(syntax-object-expression +e) +(join-wraps +w +(syntax-object-wrap +e))) +'no))))) +(match-each (lambda (e p k w) +(if (pair? e) +((lambda (first) +(if (eq? first 'no) +first +((lambda (rest) +(if (eq? rest +'no) +rest +(cons first +rest))) +(match-each +(cdr e) +p +k +w)))) +(match (car e) p k w '())) +(if (null? e) +'() +(if (syntax-object? e) +(match-each +(syntax-object-expression +e) +p +k +(join-wraps +w +(syntax-object-wrap +e))) +'no)))))) +(set! syntax-dispatch +(lambda (expression pattern keys) +(match +expression +pattern +keys +empty-wrap +'()))))))))) +(syncase:install-global-transformer +'let +(lambda (x) +((lambda (g00095) +((lambda (g00096) +((lambda (g00094) +(if (not (eq? g00094 'no)) +(apply +(lambda (__ _x _v _e1 _e2) +(if (syncase:andmap identifier? _x) +(cons (cons '#(syntax-object +lambda +(top)) +(cons _x +(cons _e1 _e2))) +_v) +(g00096))) +g00094) +(g00096))) +(syntax-dispatch +g00095 +'(pair (any) +pair +(each pair (any) pair (any) atom) +pair +(any) +each +any) +(vector)))) +(lambda () +((lambda (g00098) +((lambda (g00099) +((lambda (g00097) +(if (not (eq? g00097 'no)) +(apply +(lambda (__ _f _x _v _e1 _e2) +(if (syncase:andmap +identifier? +(cons _f _x)) +(cons (list '#(syntax-object +letrec +(top)) +(list (list _f +(cons '#(syntax-object +lambda +(top)) +(cons _x +(cons _e1 +_e2))))) +_f) +_v) +(g00099))) +g00097) +(g00099))) +(syntax-dispatch +g00098 +'(pair (any) +pair +(any) +pair +(each pair (any) pair (any) atom) +pair +(any) +each +any) +(vector)))) +(lambda () (syntax-error g00098)))) +g00095)))) +x))) +(syncase:install-global-transformer +'syntax-case +((lambda () +(letrec ((syncase:build-dispatch-call (lambda (args body val) +((lambda (g00046) +((lambda (g00045) +(if (not (eq? g00045 +'no)) +body +((lambda (g00048) +((lambda (g00047) +(if (not (eq? g00047 +'no)) +((lambda (_arg1) +((lambda (g00066) +((lambda (g00065) +(if (not (eq? g00065 +'no)) +((lambda (_body +_val) +(list (list '#(syntax-object +syntax-lambda +(top)) +(list _arg1) +_body) +(list '#(syntax-object +car +(top)) +_val))) +(car g00065) +(cadr g00065)) +(syntax-error +g00066))) +(syntax-dispatch +g00066 +'(pair (any) +pair +(any) +atom) +(vector)))) +(list body +val))) +(car g00047)) +((lambda (g00050) +((lambda (g00049) +(if (not (eq? g00049 +'no)) +((lambda (_arg1 +_arg2) +((lambda (g00064) +((lambda (g00063) +(if (not (eq? g00063 +'no)) +((lambda (_body +_val) +(list (list '#(syntax-object +syntax-lambda +(top)) +(list _arg1 +_arg2) +_body) +(list '#(syntax-object +car +(top)) +_val) +(list '#(syntax-object +cadr +(top)) +_val))) +(car g00063) +(cadr g00063)) +(syntax-error +g00064))) +(syntax-dispatch +g00064 +'(pair (any) +pair +(any) +atom) +(vector)))) +(list body +val))) +(car g00049) +(cadr g00049)) +((lambda (g00052) +((lambda (g00051) +(if (not (eq? g00051 +'no)) +((lambda (_arg1 +_arg2 +_arg3) +((lambda (g00062) +((lambda (g00061) +(if (not (eq? g00061 +'no)) +((lambda (_body +_val) +(list (list '#(syntax-object +syntax-lambda +(top)) +(list _arg1 +_arg2 +_arg3) +_body) +(list '#(syntax-object +car +(top)) +_val) +(list '#(syntax-object +cadr +(top)) +_val) +(list '#(syntax-object +caddr +(top)) +_val))) +(car g00061) +(cadr g00061)) +(syntax-error +g00062))) +(syntax-dispatch +g00062 +'(pair (any) +pair +(any) +atom) +(vector)))) +(list body +val))) +(car g00051) +(cadr g00051) +(caddr +g00051)) +((lambda (g00054) +((lambda (g00053) +(if (not (eq? g00053 +'no)) +((lambda (_arg1 +_arg2 +_arg3 +_arg4) +((lambda (g00060) +((lambda (g00059) +(if (not (eq? g00059 +'no)) +((lambda (_body +_val) +(list (list '#(syntax-object +syntax-lambda +(top)) +(list _arg1 +_arg2 +_arg3 +_arg4) +_body) +(list '#(syntax-object +car +(top)) +_val) +(list '#(syntax-object +cadr +(top)) +_val) +(list '#(syntax-object +caddr +(top)) +_val) +(list '#(syntax-object +cadddr +(top)) +_val))) +(car g00059) +(cadr g00059)) +(syntax-error +g00060))) +(syntax-dispatch +g00060 +'(pair (any) +pair +(any) +atom) +(vector)))) +(list body +val))) +(car g00053) +(cadr g00053) +(caddr +g00053) +(cadddr +g00053)) +((lambda (g00056) +((lambda (g00055) +(if (not (eq? g00055 +'no)) +((lambda (_arg) +((lambda (g00058) +((lambda (g00057) +(if (not (eq? g00057 +'no)) +((lambda (_body +_val) +(list '#(syntax-object +apply +(top)) +(list '#(syntax-object +syntax-lambda +(top)) +_arg +_body) +_val)) +(car g00057) +(cadr g00057)) +(syntax-error +g00058))) +(syntax-dispatch +g00058 +'(pair (any) +pair +(any) +atom) +(vector)))) +(list body +val))) +(car g00055)) +(syntax-error +g00056))) +(syntax-dispatch +g00056 +'(each any) +(vector)))) +g00054))) +(syntax-dispatch +g00054 +'(pair (any) +pair +(any) +pair +(any) +pair +(any) +atom) +(vector)))) +g00052))) +(syntax-dispatch +g00052 +'(pair (any) +pair +(any) +pair +(any) +atom) +(vector)))) +g00050))) +(syntax-dispatch +g00050 +'(pair (any) +pair +(any) +atom) +(vector)))) +g00048))) +(syntax-dispatch +g00048 +'(pair (any) +atom) +(vector)))) +g00046))) +(syntax-dispatch +g00046 +'(atom) +(vector)))) +args))) +(extract-bound-syntax-ids (lambda (pattern keys) +((letrec ((gen (lambda (p +n +ids) +(if (identifier? +p) +(if (key? p +keys) +ids +(cons (list p +n) +ids)) +((lambda (g00068) +((lambda (g00069) +((lambda (g00067) +(if (not (eq? g00067 +'no)) +((lambda (_x +_dots) +(if (ellipsis? +_dots) +(gen _x +(+ n +1) +ids) +(g00069))) +(car g00067) +(cadr g00067)) +(g00069))) +(syntax-dispatch +g00068 +'(pair (any) +pair +(any) +atom) +(vector)))) +(lambda () +((lambda (g00071) +((lambda (g00070) +(if (not (eq? g00070 +'no)) +((lambda (_x +_y) +(gen _x +n +(gen _y +n +ids))) +(car g00070) +(cadr g00070)) +((lambda (g00073) +((lambda (g00072) +(if (not (eq? g00072 +'no)) +((lambda (_x) +(gen _x +n +ids)) +(car g00072)) +((lambda (g00075) +((lambda (g00074) +(if (not (eq? g00074 +'no)) +((lambda (_x) +ids) +(car g00074)) +(syntax-error +g00075))) +(syntax-dispatch +g00075 +'(any) +(vector)))) +g00073))) +(syntax-dispatch +g00073 +'(vector +each +any) +(vector)))) +g00071))) +(syntax-dispatch +g00071 +'(pair (any) +any) +(vector)))) +g00068)))) +p))))) +gen) +pattern +0 +'()))) +(valid-syntax-pattern? (lambda (pattern keys) +(letrec ((check? (lambda (p +ids) +(if (identifier? +p) +(if (eq? ids +'no) +ids +(if (key? p +keys) +ids +(if (if (not (ellipsis? +p)) +(not (memid +p +ids)) +#f) +(cons p +ids) +'no))) +((lambda (g00077) +((lambda (g00078) +((lambda (g00076) +(if (not (eq? g00076 +'no)) +((lambda (_x +_dots) +(if (ellipsis? +_dots) +(check? +_x +ids) +(g00078))) +(car g00076) +(cadr g00076)) +(g00078))) +(syntax-dispatch +g00077 +'(pair (any) +pair +(any) +atom) +(vector)))) +(lambda () +((lambda (g00080) +((lambda (g00079) +(if (not (eq? g00079 +'no)) +((lambda (_x +_y) +(check? +_x +(check? +_y +ids))) +(car g00079) +(cadr g00079)) +((lambda (g00082) +((lambda (g00081) +(if (not (eq? g00081 +'no)) +((lambda (_x) +(check? +_x +ids)) +(car g00081)) +((lambda (g00084) +((lambda (g00083) +(if (not (eq? g00083 +'no)) +((lambda (_x) +ids) +(car g00083)) +(syntax-error +g00084))) +(syntax-dispatch +g00084 +'(any) +(vector)))) +g00082))) +(syntax-dispatch +g00082 +'(vector +each +any) +(vector)))) +g00080))) +(syntax-dispatch +g00080 +'(pair (any) +any) +(vector)))) +g00077)))) +p))))) +(not (eq? (check? +pattern +'()) +'no))))) +(valid-keyword? (lambda (k) +(if (identifier? k) +(not (free-identifier=? +k +'...)) +#f))) +(convert-syntax-dispatch-pattern (lambda (pattern +keys) +((letrec ((gen (lambda (p) +(if (identifier? +p) +(if (key? p +keys) +(cons '#(syntax-object +free-id +(top)) +(key-index +p +keys)) +(list '#(syntax-object +any +(top)))) +((lambda (g00086) +((lambda (g00087) +((lambda (g00085) +(if (not (eq? g00085 +'no)) +((lambda (_x +_dots) +(if (ellipsis? +_dots) +(cons '#(syntax-object +each +(top)) +(gen _x)) +(g00087))) +(car g00085) +(cadr g00085)) +(g00087))) +(syntax-dispatch +g00086 +'(pair (any) +pair +(any) +atom) +(vector)))) +(lambda () +((lambda (g00089) +((lambda (g00088) +(if (not (eq? g00088 +'no)) +((lambda (_x +_y) +(cons '#(syntax-object +pair +(top)) +(cons (gen _x) +(gen _y)))) +(car g00088) +(cadr g00088)) +((lambda (g00091) +((lambda (g00090) +(if (not (eq? g00090 +'no)) +((lambda (_x) +(cons '#(syntax-object +vector +(top)) +(gen _x))) +(car g00090)) +((lambda (g00093) +((lambda (g00092) +(if (not (eq? g00092 +'no)) +((lambda (_x) +(cons '#(syntax-object +atom +(top)) +p)) +(car g00092)) +(syntax-error +g00093))) +(syntax-dispatch +g00093 +'(any) +(vector)))) +g00091))) +(syntax-dispatch +g00091 +'(vector +each +any) +(vector)))) +g00089))) +(syntax-dispatch +g00089 +'(pair (any) +any) +(vector)))) +g00086)))) +p))))) +gen) +pattern))) +(key-index (lambda (p keys) +(- (length keys) +(length (memid p keys))))) +(key? (lambda (p keys) +(if (identifier? p) (memid p keys) #f))) +(memid (lambda (i ids) +(if (not (null? ids)) +(if (bound-identifier=? i (car ids)) +ids +(memid i (cdr ids))) +#f))) +(ellipsis? (lambda (x) +(if (identifier? x) +(free-identifier=? x '...) +#f)))) +(lambda (x) +((lambda (g00030) +((lambda (g00031) +((lambda (g00029) +(if (not (eq? g00029 'no)) +((lambda (__ _val _key) +(if (syncase:andmap valid-keyword? _key) +(list '#(syntax-object +syntax-error +(top)) +_val) +(g00031))) +(car g00029) +(cadr g00029) +(caddr g00029)) +(g00031))) +(syntax-dispatch +g00030 +'(pair (any) +pair +(any) +pair +(each any) +atom) +(vector)))) +(lambda () +((lambda (g00033) +((lambda (g00034) +((lambda (g00032) +(if (not (eq? g00032 'no)) +(apply +(lambda (__ +_val +_key +_pat +_exp) +(if (if (identifier? +_pat) +(if (syncase:andmap +valid-keyword? +_key) +(syncase:andmap +(lambda (x) +(not (free-identifier=? +_pat +x))) +(cons '... +_key)) +#f) +#f) +(list (list '#(syntax-object +syntax-lambda +(top)) +(list (list _pat +0)) +_exp) +_val) +(g00034))) +g00032) +(g00034))) +(syntax-dispatch +g00033 +'(pair (any) +pair +(any) +pair +(each any) +pair +(pair (any) pair (any) atom) +atom) +(vector)))) +(lambda () +((lambda (g00036) +((lambda (g00037) +((lambda (g00035) +(if (not (eq? g00035 'no)) +(apply +(lambda (__ +_val +_key +_pat +_exp +_e1 +_e2 +_e3) +(if (if (syncase:andmap +valid-keyword? +_key) +(valid-syntax-pattern? +_pat +_key) +#f) +((lambda (g00044) +((lambda (g00043) +(if (not (eq? g00043 +'no)) +((lambda (_pattern +_y +_call) +(list '#(syntax-object +let +(top)) +(list (list '#(syntax-object +x +(top)) +_val)) +(list '#(syntax-object +let +(top)) +(list (list _y +(list '#(syntax-object +syntax-dispatch +(top)) +'#(syntax-object +x +(top)) +(list '#(syntax-object +quote +(top)) +_pattern) +(list '#(syntax-object +syntax +(top)) +(list->vector +_key))))) +(list '#(syntax-object +if +(top)) +(list '#(syntax-object +not +(top)) +(list '#(syntax-object +eq? +(top)) +_y +(list '#(syntax-object +quote +(top)) +'#(syntax-object +no +(top))))) +_call +(cons '#(syntax-object +syntax-case +(top)) +(cons '#(syntax-object +x +(top)) +(cons _key +(map (lambda (__e1 +__e2 +__e3) +(cons __e1 +(cons __e2 +__e3))) +_e1 +_e2 +_e3)))))))) +(car g00043) +(cadr g00043) +(caddr +g00043)) +(syntax-error +g00044))) +(syntax-dispatch +g00044 +'(pair (any) +pair +(any) +pair +(any) +atom) +(vector)))) +(list (convert-syntax-dispatch-pattern +_pat +_key) +'#(syntax-object +y +(top)) +(syncase:build-dispatch-call +(extract-bound-syntax-ids +_pat +_key) +_exp +'#(syntax-object +y +(top))))) +(g00037))) +g00035) +(g00037))) +(syntax-dispatch +g00036 +'(pair (any) +pair +(any) +pair +(each any) +pair +(pair (any) +pair +(any) +atom) +each +pair +(any) +pair +(any) +each +any) +(vector)))) +(lambda () +((lambda (g00039) +((lambda (g00040) +((lambda (g00038) +(if (not (eq? g00038 +'no)) +(apply +(lambda (__ +_val +_key +_pat +_fender +_exp +_e1 +_e2 +_e3) +(if (if (syncase:andmap +valid-keyword? +_key) +(valid-syntax-pattern? +_pat +_key) +#f) +((lambda (g00042) +((lambda (g00041) +(if (not (eq? g00041 +'no)) +((lambda (_pattern +_y +_dorest +_call) +(list '#(syntax-object +let +(top)) +(list (list '#(syntax-object +x +(top)) +_val)) +(list '#(syntax-object +let +(top)) +(list (list _dorest +(list '#(syntax-object +lambda +(top)) +'() +(cons '#(syntax-object +syntax-case +(top)) +(cons '#(syntax-object +x +(top)) +(cons _key +(map (lambda (__e1 +__e2 +__e3) +(cons __e1 +(cons __e2 +__e3))) +_e1 +_e2 +_e3))))))) +(list '#(syntax-object +let +(top)) +(list (list _y +(list '#(syntax-object +syntax-dispatch +(top)) +'#(syntax-object +x +(top)) +(list '#(syntax-object +quote +(top)) +_pattern) +(list '#(syntax-object +syntax +(top)) +(list->vector +_key))))) +(list '#(syntax-object +if +(top)) +(list '#(syntax-object +not +(top)) +(list '#(syntax-object +eq? +(top)) +_y +(list '#(syntax-object +quote +(top)) +'#(syntax-object +no +(top))))) +_call +(list _dorest)))))) +(car g00041) +(cadr g00041) +(caddr +g00041) +(cadddr +g00041)) +(syntax-error +g00042))) +(syntax-dispatch +g00042 +'(pair (any) +pair +(any) +pair +(any) +pair +(any) +atom) +(vector)))) +(list (convert-syntax-dispatch-pattern +_pat +_key) +'#(syntax-object +y +(top)) +'#(syntax-object +dorest +(top)) +(syncase:build-dispatch-call +(extract-bound-syntax-ids +_pat +_key) +(list '#(syntax-object +if +(top)) +_fender +_exp +(list '#(syntax-object +dorest +(top)))) +'#(syntax-object +y +(top))))) +(g00040))) +g00038) +(g00040))) +(syntax-dispatch +g00039 +'(pair (any) +pair +(any) +pair +(each any) +pair +(pair (any) +pair +(any) +pair +(any) +atom) +each +pair +(any) +pair +(any) +each +any) +(vector)))) +(lambda () +(syntax-error +g00039)))) +g00036)))) +g00033)))) +g00030)))) +x))))))) diff --git a/scaglob.scm b/scaglob.scm new file mode 100644 index 0000000..32a027c --- /dev/null +++ b/scaglob.scm @@ -0,0 +1,32 @@ +;;; "scaglob.scm" syntax-case initializations +;;; Copyright (C) 1992 R. Kent Dybvig +;;; +;;; Permission to copy this software, in whole or in part, to use this +;;; software for any lawful purpose, and to redistribute this software +;;; is granted subject to the restriction that all copies made of this +;;; software must include this copyright notice in full. This software +;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED, +;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY +;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE +;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY +;;; NATURE WHATSOEVER. + +;;; From: Harald Hanche-Olsen + +;;; init.ss +;;; Robert Hieb & Kent Dybvig +;;; 92/06/18 + +; These initializations are done here rather than "expand.ss" so that +; "expand.ss" can be loaded twice (for bootstrapping purposes). + +(define expand-syntax #f) +(define syntax-dispatch #f) +(define generate-temporaries #f) +(define identifier? #f) +(define syntax-error #f) +(define syntax-object->datum #f) +(define bound-identifier=? #f) +(define free-identifier=? #f) +(define syncase:install-global-transformer #f) +(define implicit-identifier #f) diff --git a/scainit.scm b/scainit.scm new file mode 100644 index 0000000..1103bc6 --- /dev/null +++ b/scainit.scm @@ -0,0 +1,103 @@ +;;; "scainit.scm" Syntax-case macros port to SLIB -*- Scheme -*- +;;; Copyright (C) 1992 R. Kent Dybvig +;;; +;;; Permission to copy this software, in whole or in part, to use this +;;; software for any lawful purpose, and to redistribute this software +;;; is granted subject to the restriction that all copies made of this +;;; software must include this copyright notice in full. This software +;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED, +;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY +;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE +;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY +;;; NATURE WHATSOEVER. + +;;; From: Harald Hanche-Olsen + +;;; compat.ss +;;; Robert Hieb & Kent Dybvig +;;; 92/06/18 + +(require 'common-list-functions) ;to pick up EVERY +(define syncase:andmap comlist:every) + +; In Chez Scheme "(syncase:void)" returns an object that is ignored by the +; REP loop. It is returned whenever a "nonspecified" value is specified +; by the standard. The following should pick up an appropriate value. + +(define syncase:void + (let ((syncase:void-object (if #f #f))) + (lambda () syncase:void-object))) + +(define syncase:eval-hook slib:eval) + +(define syncase:error-hook slib:error) + +(define syncase:new-symbol-hook + (let ((c 0)) + (lambda (string) + (set! c (+ c 1)) + (string->symbol + (string-append string ":Sca" (number->string c)))))) + +(define syncase:put-global-definition-hook #f) +(define syncase:get-global-definition-hook #f) +(let ((*macros* '())) + (set! syncase:put-global-definition-hook + (lambda (symbol binding) + (let ((pair (assq symbol *macros*))) + (if pair + (set-cdr! pair binding) + (set! *macros* (cons (cons symbol binding) *macros*)))))) + (set! syncase:get-global-definition-hook + (lambda (symbol) + (let ((pair (assq symbol *macros*))) + (and pair (cdr pair)))))) + + +;;;! expand.pp requires list* +(define (syncase:list* . args) + (if (null? args) + '() + (let ((r (reverse args))) + (append (reverse (cdr r)) + (car r) ; Last arg + '())))) ; Make sure the last arg is copied + +(define syntax-error syncase:error-hook) +(define impl-error slib:error) + +(define base:eval slib:eval) +(define syncase:eval base:eval) +(define macro:eval base:eval) +(define syncase:expand #f) +(define macro:expand #f) +(define (syncase:expand-install-hook expand) + (set! syncase:eval (lambda (x) (base:eval (expand x)))) + (set! macro:eval syncase:eval) + (set! syncase:expand expand) + (set! macro:expand syncase:expand)) +;;; We Need This for bootstrapping purposes: +(define (syncase:load ) + (slib:eval-load syncase:eval)) +(define macro:load syncase:load) + +(define syncase:sanity-check #f) +;;; LOADING THE SYSTEM ITSELF: +(let ((here (lambda (file) + (in-vicinity (library-vicinity) file))) + (scmhere (lambda (file) + (in-vicinity (library-vicinity) file (scheme-file-suffix))))) + (for-each (lambda (file) (slib:load (here file))) + '("scaoutp" + "scaglob" + "scaexpp")) + (syncase:expand-install-hook expand-syntax) + (syncase:load (here "scamacr")) + (set! syncase:sanity-check + (lambda () + (syncase:load (scmhere "sca-exp")) + (syncase:expand-install-hook expand-syntax) + (syncase:load (scmhere "sca-macr"))))) + +(provide 'syntax-case) +(provide 'macro) diff --git a/scamacr.scm b/scamacr.scm new file mode 100644 index 0000000..016d7fb --- /dev/null +++ b/scamacr.scm @@ -0,0 +1,181 @@ +;;; "scamacr.scm" syntax-case macros for Scheme constructs +;;; Copyright (C) 1992 R. Kent Dybvig +;;; +;;; Permission to copy this software, in whole or in part, to use this +;;; software for any lawful purpose, and to redistribute this software +;;; is granted subject to the restriction that all copies made of this +;;; software must include this copyright notice in full. This software +;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED, +;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY +;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE +;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY +;;; NATURE WHATSOEVER. + +;;; Written by Robert Hieb & Kent Dybvig + +;;; This file was munged by a simple minded sed script since it left +;;; its original authors' hands. See syncase.sh for the horrid details. + +;;; macro-defs.ss +;;; Robert Hieb & Kent Dybvig +;;; 92/06/18 + +(define-syntax with-syntax + (lambda (x) + (syntax-case x () + ((_ () e1 e2 ...) + (syntax (begin e1 e2 ...))) + ((_ ((out in)) e1 e2 ...) + (syntax (syntax-case in () (out (begin e1 e2 ...))))) + ((_ ((out in) ...) e1 e2 ...) + (syntax (syntax-case (list in ...) () + ((out ...) (begin e1 e2 ...)))))))) + +(define-syntax syntax-rules + (lambda (x) + (syntax-case x () + ((_ (k ...) ((keyword . pattern) template) ...) + (with-syntax (((dummy ...) + (generate-temporaries (syntax (keyword ...))))) + (syntax (lambda (x) + (syntax-case x (k ...) + ((dummy . pattern) (syntax template)) + ...)))))))) + +(define-syntax or + (lambda (x) + (syntax-case x () + ((_) (syntax #f)) + ((_ e) (syntax e)) + ((_ e1 e2 e3 ...) + (syntax (let ((t e1)) (if t t (or e2 e3 ...)))))))) + +(define-syntax and + (lambda (x) + (syntax-case x () + ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f))) + ((_ e) (syntax e)) + ((_) (syntax #t))))) + +(define-syntax cond + (lambda (x) + (syntax-case x (else =>) + ((_ (else e1 e2 ...)) + (syntax (begin e1 e2 ...))) + ((_ (e0)) + (syntax (let ((t e0)) (if t t)))) + ((_ (e0) c1 c2 ...) + (syntax (let ((t e0)) (if t t (cond c1 c2 ...))))) + ((_ (e0 => e1)) (syntax (let ((t e0)) (if t (e1 t))))) + ((_ (e0 => e1) c1 c2 ...) + (syntax (let ((t e0)) (if t (e1 t) (cond c1 c2 ...))))) + ((_ (e0 e1 e2 ...)) (syntax (if e0 (begin e1 e2 ...)))) + ((_ (e0 e1 e2 ...) c1 c2 ...) + (syntax (if e0 (begin e1 e2 ...) (cond c1 c2 ...))))))) + +(define-syntax let* + (lambda (x) + (syntax-case x () + ((let* () e1 e2 ...) + (syntax (let () e1 e2 ...))) + ((let* ((x1 v1) (x2 v2) ...) e1 e2 ...) + (comlist:every identifier? (syntax (x1 x2 ...))) + (syntax (let ((x1 v1)) (let* ((x2 v2) ...) e1 e2 ...))))))) + +(define-syntax case + (lambda (x) + (syntax-case x (else) + ((_ v (else e1 e2 ...)) + (syntax (begin v e1 e2 ...))) + ((_ v ((k ...) e1 e2 ...)) + (syntax (if (memv v '(k ...)) (begin e1 e2 ...)))) + ((_ v ((k ...) e1 e2 ...) c1 c2 ...) + (syntax (let ((x v)) + (if (memv x '(k ...)) + (begin e1 e2 ...) + (case x c1 c2 ...)))))))) + +(define-syntax do + (lambda (orig-x) + (syntax-case orig-x () + ((_ ((var init . step) ...) (e0 e1 ...) c ...) + (with-syntax (((step ...) + (map (lambda (v s) + (syntax-case s () + (() v) + ((e) (syntax e)) + (_ (syntax-error orig-x)))) + (syntax (var ...)) + (syntax (step ...))))) + (syntax-case (syntax (e1 ...)) () + (() (syntax (let doloop ((var init) ...) + (if (not e0) + (begin c ... (doloop step ...)))))) + ((e1 e2 ...) + (syntax (let doloop ((var init) ...) + (if e0 + (begin e1 e2 ...) + (begin c ... (doloop step ...)))))))))))) + +(define-syntax quasiquote + (letrec + ((gen-cons + (lambda (x y) + (syntax-case x (quote) + ((quote x) + (syntax-case y (quote list) + ((quote y) (syntax (quote (x . y)))) + ((list y ...) (syntax (list (quote x) y ...))) + (y (syntax (cons (quote x) y))))) + (x (syntax-case y (quote list) + ((quote ()) (syntax (list x))) + ((list y ...) (syntax (list x y ...))) + (y (syntax (cons x y)))))))) + + (gen-append + (lambda (x y) + (syntax-case x (quote list cons) + ((quote (x1 x2 ...)) + (syntax-case y (quote) + ((quote y) (syntax (quote (x1 x2 ... . y)))) + (y (syntax (append (quote (x1 x2 ...) y)))))) + ((quote ()) y) + ((list x1 x2 ...) + (gen-cons (syntax x1) (gen-append (syntax (list x2 ...)) y))) + (x (syntax-case y (quote list) + ((quote ()) (syntax x)) + (y (syntax (append x y)))))))) + + (gen-vector + (lambda (x) + (syntax-case x (quote list) + ((quote (x ...)) (syntax (quote #(x ...)))) + ((list x ...) (syntax (vector x ...))) + (x (syntax (list->vector x)))))) + + (gen + (lambda (p lev) + (syntax-case p (unquote unquote-splicing quasiquote) + ((unquote p) + (if (= lev 0) + (syntax p) + (gen-cons (syntax (quote unquote)) + (gen (syntax (p)) (- lev 1))))) + (((unquote-splicing p) . q) + (if (= lev 0) + (gen-append (syntax p) (gen (syntax q) lev)) + (gen-cons (gen-cons (syntax (quote unquote-splicing)) + (gen (syntax p) (- lev 1))) + (gen (syntax q) lev)))) + ((quasiquote p) + (gen-cons (syntax (quote quasiquote)) + (gen (syntax (p)) (+ lev 1)))) + ((p . q) + (gen-cons (gen (syntax p) lev) (gen (syntax q) lev))) + (#(x ...) (gen-vector (gen (syntax (x ...)) lev))) + (p (syntax (quote p))))))) + + (lambda (x) + (syntax-case x () + ((- e) (gen (syntax e) 0)))))) + diff --git a/scanf.scm b/scanf.scm new file mode 100644 index 0000000..b1ae30a --- /dev/null +++ b/scanf.scm @@ -0,0 +1,351 @@ +;;;;"scanf.scm" implemenation of formated input +;Copyright (C) 1996 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; Originally jjb@isye.gatech.edu (John Bartholdi) wrote some public +;;; domain code for a subset of scanf, but it was too difficult to +;;; extend to POSIX pattern compliance. Jan 96, I rewrote the scanf +;;; functions starting from the POSIX man pages. + +(require 'string-port) + +(define (stdio:scan-and-set format-string input-port . args) + (define setters args) + (if (equal? '(#f) args) (set! args #f)) + (cond + ((not (equal? "" format-string)) + (call-with-input-string + format-string + (lambda (format-port) + + (define items '()) + (define chars-scanned 0) + (define assigned-count 0) + + (define (char-non-numeric? c) (not (char-numeric? c))) + + (define (flush-whitespace port) + (do ((c (peek-char port) (peek-char port)) + (i 0 (+ 1 i))) + ((or (eof-object? c) (not (char-whitespace? c))) i) + (read-char port))) + + (define (flush-whitespace-input) + (set! chars-scanned (+ (flush-whitespace input-port) chars-scanned))) + + (define (read-input-char) + (set! chars-scanned (+ 1 chars-scanned)) + (read-char input-port)) + + (define (add-item report-field? next-item) + (cond (args + (cond ((null? setters) + (slib:error 'scanf "not enough variables for format" + format-string)) + ((not next-item) (return)) + ((not report-field?) (loop1)) + (else + (let ((suc ((car setters) next-item))) + (cond ((not (boolean? suc)) + (slib:warn 'scanf "setter returned non-boolean" + suc))) + (set! setters (cdr setters)) + (cond ((not suc) (return)) + ((eqv? -1 report-field?) (loop1)) + (else + (set! assigned-count (+ 1 assigned-count)) + (loop1))))))) + ((not next-item) (return)) + (report-field? (set! items (cons next-item items)) + (loop1)) + (else (loop1)))) + + (define (return) + (cond ((and (zero? chars-scanned) + (eof-object? (peek-char input-port))) + (peek-char input-port)) + (args assigned-count) + (else (reverse items)))) + + (define (read-string width separator?) + (cond (width + (let ((str (make-string width))) + (do ((i 0 (+ 1 i))) + ((>= i width) + str) + (let ((c (peek-char input-port))) + (cond ((eof-object? c) + (set! str (substring str 0 i)) + (set! i width)) + ((separator? c) + (set! str (if (zero? i) "" (substring str 0 i))) + (set! i width)) + (else + (string-set! str i (read-input-char)))))))) + (else + (do ((c (peek-char input-port) (peek-char input-port)) + (l '() (cons c l))) + ((or (eof-object? c) (separator? c)) + (list->string (reverse l))) + (read-input-char))))) + + (define (read-word width separator?) + (let ((l (read-string width separator?))) + (if (zero? (string-length l)) #f l))) + + (define (loop1) + (define fc (read-char format-port)) + (cond + ((eof-object? fc) + (return)) + ((char-whitespace? fc) + (flush-whitespace format-port) + (flush-whitespace-input) + (loop1)) + ((eqv? #\% fc) ; interpret next format + (set! fc (read-char format-port)) + (let ((report-field? (not (eqv? #\* fc))) + (width #f)) + + (define (width--) (if width (set! width (+ -1 width)))) + + (define (read-u) + (string->number (read-string width char-non-numeric?))) + + (define (read-o) + (string->number + (read-string + width + (lambda (c) (not (memv c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7))))) + 8)) + + (define (read-x) + (string->number + (read-string + width + (lambda (c) (not (memv (char-downcase c) + '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 + #\9 #\a #\b #\c #\d #\e #\f))))) + 16)) + + (define (read-radixed-unsigned) + (let ((c (peek-char input-port))) + (case c + ((#\0) (read-input-char) + (width--) + (set! c (peek-char input-port)) + (case c + ((#\x #\X) (read-input-char) + (width--) + (read-x)) + (else (read-o)))) + (else (read-u))))) + + (define (read-ui) + (let* ((dot? #f) + (mantissa (read-word + width + (lambda (c) + (not (or (char-numeric? c) + (cond (dot? #f) + ((eqv? #\. c) + (set! dot? #t) + #t) + (else #f))))))) + (exponent (cond + ((not mantissa) #f) + ((and (or (not width) (> width 1)) + (memv (peek-char input-port) '(#\E #\e))) + (read-input-char) + (width--) + (let ((expsign + (case (peek-char input-port) + ((#\-) (read-input-char) + (width--) + "-") + ((#\+) (read-input-char) + (width--) + "+") + (else ""))) + (expint + (and + (or (not width) (positive? width)) + (read-word width char-non-numeric?)))) + (and expint (string-append + "e" expsign expint)))) + (else #f)))) + (and mantissa + (string->number + (string-append + "#i" (or mantissa "") (or exponent "")))))) + + (define (read-signed proc) + (case (peek-char input-port) + ((#\-) (read-input-char) + (width--) + (let ((ret (proc))) + (and ret (- ret)))) + ((#\+) (read-input-char) + (width--) + (proc)) + (else (proc)))) + + ;;(trace read-word read-signed read-ui read-radixed-unsigned read-x read-o read-u) + + (cond ((not report-field?) (set! fc (read-char format-port)))) + (if (char-numeric? fc) (set! width 0)) + (do () ((or (eof-object? fc) (char-non-numeric? fc))) + (set! width (+ (* 10 width) (string->number (string fc)))) + (set! fc (read-char format-port))) + (case fc ;ignore h,l,L modifiers. + ((#\h #\l #\L) (set! fc (read-char format-port)))) + (case fc + ((#\n) (if (not report-field?) + (slib:error 'scanf "not saving %n??")) + (add-item -1 chars-scanned)) ;-1 is special flag. + ((#\c #\C) + (if (not width) (set! width 1)) + (let ((str (make-string width))) + (do ((i 0 (+ 1 i))) + ((>= i width) + (add-item report-field? str)) + (let ((c (read-char input-port))) + (cond ((eof-object? c) + (set! str c) + (set! i width)) + (else (string-set! str i c))))))) + ((#\s #\S) + ;;(flush-whitespace-input) + (add-item report-field? (read-word width char-whitespace?))) + ((#\[) + (set! fc (read-char format-port)) + (let ((allbut #f)) + (case fc + ((#\^) (set! allbut #t) + (set! fc (read-char format-port)))) + + (let scanloop ((scanset (list fc))) + (set! fc (read-char format-port)) + (case fc + ((#\-) + (set! fc (peek-char format-port)) + (cond + ((and (charinteger fc)) + (do ((i (char->integer (car scanset)) (+ 1 i))) + ((> i fc) (scanloop scanset)) + (set! scanset (cons (integer->char i) scanset)))) + (else (scanloop (cons #\- scanset))))) + ((#\]) + (add-item report-field? + (read-word + width + (if allbut (lambda (c) (memv c scanset)) + (lambda (c) (not (memv c scanset))))))) + (else (cond + ((eof-object? fc) + (slib:error 'scanf "unmatched [ in format")) + (else (scanloop (cons fc scanset))))))))) + ((#\o #\O) + ;;(flush-whitespace-input) + (add-item report-field? (read-o))) + ((#\u #\U) + ;;(flush-whitespace-input) + (add-item report-field? (read-u))) + ((#\d #\D) + ;;(flush-whitespace-input) + (add-item report-field? (read-signed read-u))) + ((#\x #\X) + ;;(flush-whitespace-input) + (add-item report-field? (read-x))) + ((#\e #\E #\f #\F #\g #\G) + ;;(flush-whitespace-input) + (add-item report-field? (read-signed read-ui))) + ((#\i) + ;;(flush-whitespace-input) + (add-item report-field? (read-signed read-radixed-unsigned))) + ((#\%) + (cond ((or width (not report-field?)) + (slib:error 'SCANF "%% has modifiers?")) + ((eqv? #\% (read-input-char)) + (loop1)) + (else (return)))) + (else (slib:error 'SCANF + "Unknown format directive:" fc))))) + ((eqv? (peek-char input-port) fc) + (read-input-char) + (loop1)) + (else (return)))) + + (loop1)))) + (args 0) + (else '()))) + +;;;This implements a Scheme-oriented version of SCANF: returns a list of +;;;objects read (rather than set!-ing values). + +(define (scanf-read-list format-string . optarg) + (define input-port + (cond ((null? optarg) (current-input-port)) + ((not (null? (cdr optarg))) + (slib:error 'scanf-read-list 'wrong-number-of-args optarg)) + (else (car optarg)))) + (cond ((input-port? input-port) + (stdio:scan-and-set format-string input-port #f)) + ((string? input-port) + (call-with-input-string + input-port (lambda (input-port) + (stdio:scan-and-set format-string input-port #f)))) + (else (slib:error 'scanf-read-list "argument not port" input-port)))) + +(define (stdio:setter-procedure sexp) + (let ((v (gentemp))) + (cond ((symbol? sexp) `(lambda (,v) (set! ,sexp ,v) #t)) + ((not (and (pair? sexp) (list? sexp))) + (slib:error 'scanf "setter expression not understood" sexp)) + (else + (case (car sexp) + ((vector-ref) `(lambda (,v) (vector-set! ,@(cdr sexp) ,v) #t)) + ((substring) + (require 'rev2-procedures) + `(lambda (,v) (substring-move-left! + ,v 0 (min (string-length ,v) + (- ,(cadddr sexp) ,(caddr sexp))) + ,(cadr sexp) ,(caddr sexp)) + #t)) + ((list-ref) + (require 'rev4-optional-procedures) + `(lambda (,v) (set-car! (list-tail ,@(cdr sexp)) ,v) #t)) + ((car) `(lambda (,v) (set-car! ,@(cdr sexp) ,v) #t)) + ((cdr) `(lambda (,v) (set-cdr! ,@(cdr sexp) ,v) #t)) + (else (slib:error 'scanf "setter not known" sexp))))))) + +(defmacro scanf (format-string . args) + `(stdio:scan-and-set ,format-string (current-input-port) + ,@(map stdio:setter-procedure args))) + +(defmacro sscanf (str format-string . args) + `(call-with-input-string + ,str (lambda (input-port) + (stdio:scan-and-set ,format-string input-port + ,@(map stdio:setter-procedure args))))) + +(defmacro fscanf (input-port format-string . args) + `(stdio:scan-and-set ,format-string ,input-port + ,@(map stdio:setter-procedure args))) diff --git a/scaoutp.scm b/scaoutp.scm new file mode 100644 index 0000000..b9730ca --- /dev/null +++ b/scaoutp.scm @@ -0,0 +1,93 @@ +;;; "scaoutp.scm" syntax-case output +;;; Copyright (C) 1992 R. Kent Dybvig +;;; +;;; Permission to copy this software, in whole or in part, to use this +;;; software for any lawful purpose, and to redistribute this software +;;; is granted subject to the restriction that all copies made of this +;;; software must include this copyright notice in full. This software +;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED, +;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY +;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE +;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY +;;; NATURE WHATSOEVER. + +;;; Written by Robert Hieb & Kent Dybvig + +;;; This file was munged by a simple minded sed script since it left +;;; its original authors' hands. See syncase.sh for the horrid details. + +;;; output.ss +;;; Robert Hieb & Kent Dybvig +;;; 92/06/18 + +; The output routines can be tailored to feed a specific system or compiler. +; They are set up here to generate the following subset of standard Scheme: + +; :== +; | +; | (set! ) +; | (define ) +; | (lambda (*) ) +; | (lambda ) +; | (lambda (+ . ) ) +; | (letrec (+) ) +; | (if ) +; | (begin ) +; | (quote ) +; :== (+) +; :== ( ) +; :== + +; Definitions are generated only at top level. + +(define syncase:build-application + (lambda (fun-exp arg-exps) + `(,fun-exp ,@arg-exps))) + +(define syncase:build-conditional + (lambda (test-exp then-exp else-exp) + `(if ,test-exp ,then-exp ,else-exp))) + +(define syncase:build-lexical-reference (lambda (var) var)) + +(define syncase:build-lexical-assignment + (lambda (var exp) + `(set! ,var ,exp))) + +(define syncase:build-global-reference (lambda (var) var)) + +(define syncase:build-global-assignment + (lambda (var exp) + `(set! ,var ,exp))) + +(define syncase:build-lambda + (lambda (vars exp) + `(lambda ,vars ,exp))) + +(define syncase:build-improper-lambda + (lambda (vars var exp) + `(lambda (,@vars . ,var) ,exp))) + +(define syncase:build-data + (lambda (exp) + `(quote ,exp))) + +(define syncase:build-identifier + (lambda (id) + `(quote ,id))) + +(define syncase:build-sequence + (lambda (exps) + (if (null? (cdr exps)) + (car exps) + `(begin ,(car exps) ,(syncase:build-sequence (cdr exps)))))) + +(define syncase:build-letrec + (lambda (vars val-exps body-exp) + (if (null? vars) + body-exp + `(letrec ,(map list vars val-exps) ,body-exp)))) + +(define syncase:build-global-definition + (lambda (var val) + `(define ,var ,val))) diff --git a/scheme2c.init b/scheme2c.init new file mode 100644 index 0000000..cace8c0 --- /dev/null +++ b/scheme2c.init @@ -0,0 +1,291 @@ +;"scheme2c.init" Initialisation for SLIB for Scheme->C on Sun -*-scheme-*- +;Copyright 1991, 1992, 1993 Aubrey Jaffer +;Copyright 1991 David Love +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;Modified by David Love (d.love@daresbury.ac.uk) 10/12/91 +;; NB this is for the 01nov91 (and, presumably, later ones, +;; although those may not need the bug fixes done at the end). +;; Earlier versions definitely aren't rev4 conformant. Check +;; `ieee-floating-point' and `system' in *features* for non-Sun un*x +;; versions and `system' and the vicinity stuff (at least) for +;; non-un*x versions. + +;; Of course, if you make serious use of library functions you'll want +;; to compile them and use Scheme->C modules. + +(define (software-type) 'UNIX) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. + +(define (scheme-implementation-type) 'Scheme->C) + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "?01nov91") + +(define (implementation-vicinity) + (case (software-type) + ((UNIX) "/usr/local/lib/scheme/") + ((VMS) "scheme$src:") + ((MS-DOS) "C:\\scheme\\"))) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +(define library-vicinity + (let ((library-path + (case (software-type) + ((UNIX) "/usr/local/lib/slib/") + ((VMS) "lib$scheme:") + ((MS-DOS) "C:\\SLIB\\") + (else "")))) + (lambda () library-path))) + +;;; *FEATURES* should be set to a list of symbols describing features +;;; of this implementation. See Template.scm for the list of feature +;;; names. + +(define *features* + '( + source ;can load scheme source files + ;(slib:load-source "filename") +; compiled ;can load compiled files + ;(slib:load-compiled "filename") + rev4-report + ;; Follows rev4 as far as I can tell, modulo '() being false, + ;; number syntax (see doc), incomplete tail recursion (see + ;; docs) and a couple of bugs in some versions -- see below. + rev3-report ;conforms to +; ieee-p1178 ;conforms to + ;; ieee conformance is ruled out by '() being false, if + ;; nothing else. + rev4-optional-procedures + rev3-procedures +; rev2-procedures + multiarg/and- + multiarg-apply + rationalize + object-hash + delay + promise + with-file + transcript + char-ready? + ieee-floating-point + full-continuation + pretty-print + format + trace ;has macros: TRACE and UNTRACE + string-port + system + ;; next two could be added easily to the interpreter +; getenv +; program-arguments + )) + +(define pretty-print pp) + +;;; (OUTPUT-PORT-WIDTH ) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT ) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +(define current-error-port + (let ((port (current-output-port))) + (lambda () port))) + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam + (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (let ((tmp (string-append "slib_" (number->string cntr)))) + (if (file-exists? tmp) (tmpnam) tmp))))) + +;;; (FILE-EXISTS? ) +(define (file-exists? f) + (case (software-type) + ((UNIX) (zero? (system (string-append "test -f " f)))) + (else (slib:error "FILE-EXISTS? not defined for " software-type)))) + +;;; (DELETE-FILE ) +(define (delete-file f) + (case (software-type) + ((UNIX) (zero? (system (string-append "rm " f)))) + (else (slib:error "DELETE-FILE not defined for " software-type)))) + +;;; FORCE-OUTPUT flushes any pending output on optional arg output port +;;; use this definition if your system doesn't have such a procedure. +(define force-output flush-buffer) + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-*PUT-FILE. +(define (call-with-output-string f) + (let ((outsp (open-output-string))) + (f outsp) + (let ((s (get-output-string outsp))) +;;; (close-output-port outsp) ;doesn't work + s))) + +(define (call-with-input-string s f) + (let* ((insp (open-input-string s)) + (res (f insp))) + (close-input-port insp) + res)) + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +(define char-code-limit 256) + +;; MOST-POSITIVE-FIXNUM is used in modular.scm +(define most-positive-fixnum 536870911) + +;;; Return argument +(define (identity x) x) + +;;; If your implementation provides eval, SLIB:EVAL is single argument +;;; eval using the top-level (user) environment. +(define slib:eval eval) + +(define-macro defmacro + (lambda (f e) + (let ((key (cadr f)) (pattern (caddr f)) (body (cdddr f))) + (e `(define-macro ,key + (let ((%transformer (lambda ,pattern ,@body))) + (lambda (%form %expr) + (%expr (apply %transformer (cdr %form)) %expr)))) + e)))) + +(define (defmacro? m) (and (getprop m '*expander*) #t)) + +(define macroexpand-1 expand-once) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (if (and (symbol? a) (getprop a '*expander*)) + (macroexpand (expand-once e)) + e)) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +(define defmacro:eval slib:eval) +(define defmacro:load load) +;;; If your implementation provides R4RS macros: +;(define macro:eval slib:eval) +;(define macro:load load) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;; define an error procedure for the library +(define (slib:error . args) + (error 'slib-error: "~a" + (apply string-append + (map + (lambda (a) + (format " ~a" a)) + args)))) + +;; define these as appropriate for your system. +(define slib:tab (integer->char 9)) +(define slib:form-feed (integer->char 12)) + +;;; bug fixes for Scheme->C (versions 28sep90, 23feb90, 01nov91): + +(let ((vers (substring (cadr (implementation-information)) 0 7))) + (if (or (string=? vers "28sep90") (string=? vers "23feb90") + (string=? vers "01nov91")) + (begin + ;; GCD fails with 0 as argument + (define old-gcd gcd) + (set! gcd (lambda args + (apply old-gcd (remv! 0 args)))) + + ;; STRING->SYMBOL doesn't allocate a new string + (set! string->symbol + (let ((fred string->symbol)) + (lambda (a) (fred (string-append a))))) + + ;; NUMBER->STRING can generate a leading #? + (set! number->string + (let ((fred number->string)) + (lambda (num . radix) + (let ((joe (apply fred num radix))) + (if (char=? #\# (string-ref joe 0)) + (substring joe 2 (string-length joe)) + joe))))) + + ;; Another bug is bad expansion of LETREC when the body starts with a + ;; DEFINE as shown by test.scm -- not fixed here. + ))) + +(define promise:force force) + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. + +(define in-vicinity string-append) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:exit (lambda args (exit))) + +;;; Here for backward compatability +(define scheme-file-suffix + (let ((suffix (case (software-type) + ((NOSVE) "_scm") + (else ".scm")))) + (lambda () suffix))) + +;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;; suffix all the module files in SLIB have. See feature 'SOURCE. + +(define (slib:load-source f) (load (string-append f (scheme-file-suffix)))) + +;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;; by compiling "foo.scm" if this implementation can compile files. +;;; See feature 'COMPILED. + +(define slib:load-compiled load) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) + +(slib:load (in-vicinity (library-vicinity) "require")) +; eof diff --git a/scheme48.init b/scheme48.init new file mode 100644 index 0000000..6e6b423 --- /dev/null +++ b/scheme48.init @@ -0,0 +1,239 @@ +;;;"scheme48.init" Initialisation for SLIB for Scheme48 -*-scheme-*- +;;; Copyright (C) 1992, 1993, 1994, 1995 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; If you know the magic incantation to make a "," command available +;;; as a scheme procedure, you can make a nifty slib function to do +;;; this (like `slib:dump' in "vscm.init"). But for now, type: +;;; make slib48 + +;;; (software-type) should be set to the generic operating system type. +;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. + +(define (software-type) 'UNIX) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. + +(define (scheme-implementation-type) 'Scheme48) + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "0.36") + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxiliary files to your Scheme +;;; implementation reside. +; For scheme48, perhaps something like /usr/local/src/scheme48/misc/ ? + +(define (implementation-vicinity) + (case (software-type) + ((UNIX) "=scheme48/") ; Translated + (else (slib:error "unrecognized software-type" software-type)))) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +(define (library-vicinity) "/usr/local/lib/slib/") + +;;; *FEATURES* should be set to a list of symbols describing features +;;; of this implementation. See Template.scm for the list of feature +;;; names. + +(define *features* + '( + source ;can load scheme source files + ;(slib:load-source "filename") +; compiled ;can load compiled files + ;(slib:load-compiled "filename") + rev4-report ;conforms to + ieee-p1178 ;conforms to + rev4-optional-procedures + multiarg/and- + multiarg-apply + rationalize + delay ;has delay and force + with-file + char-ready? ;has + values ;proposed multiple values + eval ;slib:eval is single argument eval. + dynamic-wind ;proposed dynamic-wind + full-continuation ;can return multiple times + macro ;R4RS appendix's DEFINE-SYNTAX + )) + +;;; (OUTPUT-PORT-WIDTH ) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT ) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +(define current-error-port + (access-scheme-48 'error-output-port)) + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam + (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (let ((tmp (string-append "slib_" (number->string cntr)))) + (if (file-exists? tmp) (tmpnam) tmp))))) + +;;; (FILE-EXISTS? ) +(define (file-exists? f) #f) + +;;; (DELETE-FILE ) +(define (delete-file f) #f) + +;;; FORCE-OUTPUT flushes any pending output on optional arg output port +;;; use this definition if your system doesn't have such a procedure. +(define (force-output . arg) + ((access-scheme-48 'force-output) + (if (null? arg) (current-output-port) (car arg)))) + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +(define integer->char (access-scheme-48 'ascii->char)) +(define char->integer + (let ((char->integer char->integer) + (code0 (char->integer (integer->char 0)))) + (lambda (char) (- (char->integer char) code0)))) +(define char-code-limit 256) + +;;; Workaround MODULO bug +(define modulo + (let ((modulo modulo)) + (lambda (n1 n2) + (let ((ans (modulo n1 n2))) + (if (= ans n2) (- ans ans) ans))))) + +;;; MOST-POSITIVE-FIXNUM is used in modular.scm +(define most-positive-fixnum #x1FFFFFFF) + +;;; Return argument +(define (identity x) x) + +;;; If your implementation provides eval, SLIB:EVAL is single argument +;;; eval using the top-level (user) environment. +(define slib:eval + (let ((eval eval) + (interaction-environment interaction-environment)) + (lambda (form) + (eval form (interaction-environment))))) + +;;; If your implementation provides R4RS macros: +(define macro:eval slib:eval) +(define macro:load load) + +(define *defmacros* + (list (cons 'defmacro + (lambda (name parms . body) + `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) + *defmacros*)))))) +(define (defmacro? m) (and (assq m *defmacros*) #t)) + +(define (macroexpand-1 e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) (set! a (assq a *defmacros*)) + (if a (apply (cdr a) (cdr e)) e)) + (else e))) + e)) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) + (set! a (assq a *defmacros*)) + (if a (macroexpand (apply (cdr a) (cdr e))) e)) + (else e))) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +(define base:eval slib:eval) +(define (defmacro:eval x) (base:eval (defmacro:expand* x))) +(define (defmacro:expand* x) + (require 'defmacroexpand) (apply defmacro:expand* x '())) + +(define (defmacro:load ) + (slib:eval-load defmacro:eval)) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;;; define an error procedure for the library +(define slib:error (access-scheme-48 'error)) + +;;; define these as appropriate for your system. +(define slib:tab (integer->char 9)) +(define slib:form-feed (integer->char 12)) + +;;; Support for older versions of Scheme. Not enough code for its own file. +(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) +(define t #t) +(define nil #f) + +;;; Define these if your implementation's syntax can support them and if +;;; they are not already defined. + +(define (1+ n) (+ n 1)) +(define (-1+ n) (+ n -1)) +;(define 1- -1+) + +(define in-vicinity string-append) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:exit (lambda args #f)) + +;;; Here for backward compatability +(define scheme-file-suffix + (case (software-type) + ((NOSVE) (lambda () "_scm")) + (else (lambda () ".scm")))) + +;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;; suffix all the module files in SLIB have. See feature 'SOURCE. + +(define (slib:load-source f) (load (string-append f (scheme-file-suffix)))) + +;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;; by compiling "foo.scm" if this implementation can compile files. +;;; See feature 'COMPILED. + +(define slib:load-compiled load) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) + +(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/scmacro.scm b/scmacro.scm new file mode 100644 index 0000000..47bafca --- /dev/null +++ b/scmacro.scm @@ -0,0 +1,119 @@ +;"scmacro.scm", port for Syntactic Closures macro implementation -*- Scheme -*- +;Copyright (C) 1992, 1993, 1994 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;;; Syntaxer Output Interface + +(define syntax-error slib:error) + +(define impl-error slib:error) + +(define (append-map procedure . lists) + (apply append (apply map (cons procedure lists)))) + +(define *counter* 0) + +(define (make-name-generator) + (let ((suffix-promise + (make-promise + (lambda () + (string-append "." + (number->string (begin + (set! *counter* (+ *counter* 1)) + *counter*))))))) + (lambda (identifier) + (string->symbol + (string-append "." + (symbol->string (identifier->symbol identifier)) + (promise:force suffix-promise)))))) + +(define (output/variable name) + name) + +(define (output/literal-unquoted datum) + datum) + +(define (output/literal-quoted datum);was output/constant (inefficient) + `(QUOTE ,datum)) + +(define (output/assignment name value) + `(SET! ,name ,value)) + +(define (output/top-level-definition name value) + `(DEFINE ,name ,value)) + +(define (output/conditional predicate consequent alternative) + `(IF ,predicate ,consequent ,alternative)) + +(define (output/sequence expressions) + (if (null? (cdr expressions)) + (car expressions) + `(BEGIN ,@expressions))) + +(define (output/combination operator operands) + `(,operator ,@operands)) + +(define (output/lambda pattern body) + `(LAMBDA ,pattern ,body)) + +(define (output/delay expression) + `(DELAY ,expression)) + +(define (output/unassigned) + `'*UNASSIGNED*) + +(define (output/unspecific) + `'*UNSPECIFIC*) + +(require 'promise) ; Portable support for force and delay. +(require 'record) +(require 'synchk) ; Syntax checker. + +;;; This file is the macro expander proper. +(slib:load (in-vicinity (library-vicinity) "synclo")) + +;;; These files define the R4RS syntactic environment. +(slib:load (in-vicinity (library-vicinity) "r4rsyn")) +(slib:load (in-vicinity (library-vicinity) "synrul")) + +;;; OK, time to build the databases. +(initialize-scheme-syntactic-environment!) + +;;; MACRO:EXPAND is for you to use. It takes an R4RS expression, macro-expands +;;; it, and returns the result of the macro expansion. +(define (synclo:expand expression) + (set! *counter* 0) + (compile/top-level (list expression) scheme-syntactic-environment)) +(define macro:expand synclo:expand) + +;;; Here are EVAL, EVAL! and LOAD which expand macros. You can replace the +;;; implementation's eval and load with them if you like. +(define base:eval slib:eval) +(define base:load load) + +(define (synclo:eval x) (base:eval (macro:expand x))) +(define macro:eval synclo:eval) + +(define (synclo:load ) + (slib:eval-load synclo:eval)) + +(define macro:load synclo:load) + +(provide 'syntactic-closures) +(provide 'macro) ;Here because we may have + ;(require 'sc-macro) diff --git a/scmactst.scm b/scmactst.scm new file mode 100644 index 0000000..3b71341 --- /dev/null +++ b/scmactst.scm @@ -0,0 +1,160 @@ +;;;"scmactst.scm" test syntactic closures macros +;;; From "sc-macro.doc", A Syntactic Closures Macro Facility by Chris Hanson + +(define errs '()) +(define test + (lambda (expect fun . args) + (write (cons fun args)) + (display " ==> ") + ((lambda (res) + (write res) + (newline) + (cond ((not (equal? expect res)) + (set! errs (cons (list res expect (cons fun args)) errs)) + (display " BUT EXPECTED ") + (write expect) + (newline) + #f) + (else #t))) + (if (procedure? fun) (apply fun args) (car args))))) + +(require 'syntactic-closures) + +(macro:expand + '(define-syntax push + (syntax-rules () + ((push item list) + (set! list (cons item list)))))) + +(test '(set! foo (cons bar foo)) 'push (macro:expand '(push bar foo))) + +(macro:expand + '(define-syntax push1 + (transformer + (lambda (exp env) + (let ((item + (make-syntactic-closure env '() (cadr exp))) + (list + (make-syntactic-closure env '() (caddr exp)))) + `(set! ,list (cons ,item ,list))))))) + +(test '(set! foo (cons bar foo)) 'push1 (macro:expand '(push1 bar foo))) + +(macro:expand + '(define-syntax loop + (transformer + (lambda (exp env) + (let ((body (cdr exp))) + `(call-with-current-continuation + (lambda (exit) + (let f () + ,@(map (lambda (exp) + (make-syntactic-closure env '(exit) + exp)) + body) + (f))))))))) + +(macro:expand + '(define-syntax let1 + (transformer + (lambda (exp env) + (let ((id (cadr exp)) + (init (caddr exp)) + (exp (cadddr exp))) + `((lambda (,id) + ,(make-syntactic-closure env (list id) exp)) + ,(make-syntactic-closure env '() init))))))) + +(test 93 'let1 (macro:eval '(let1 a 90 (+ a 3)))) + +(macro:expand + '(define-syntax loop-until + (syntax-rules + () + ((loop-until id init test return step) + (letrec ((loop + (lambda (id) + (if test return (loop step))))) + (loop init)))))) + +(test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33))))) + (loop 3))) + 'loop + (macro:expand '(loop-until foo 3 #t 12 33))) + +(macro:expand + '(define-syntax loop-until1 + (transformer + (lambda (exp env) + (let ((id (cadr exp)) + (init (caddr exp)) + (test (cadddr exp)) + (return (cadddr (cdr exp))) + (step (cadddr (cddr exp))) + (close + (lambda (exp free) + (make-syntactic-closure env free exp)))) + `(letrec ((loop + ,(capture-syntactic-environment + (lambda (env) + `(lambda (,id) + (,(make-syntactic-closure env '() `if) + ,(close test (list id)) + ,(close return (list id)) + (,(make-syntactic-closure env '() + `loop) + ,(close step (list id))))))))) + (loop ,(close init '())))))))) + +(test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33))))) + (loop 3))) + 'loop1 + (macro:expand '(loop-until1 foo 3 #t 12 33))) + +(test '#t 'identifier (identifier? 'a)) +;;; this needs to setup ENV. +;;;(test '#t 'identifier +;;; (identifier? (macro:expand (make-syntactic-closure env '() 'a)))) +(test #f 'identifier (identifier? "a")) +(test #f 'identifier (identifier? #\a)) +(test #f 'identifier (identifier? 97)) +(test #f 'identifier (identifier? #f)) +(test #f 'identifier (identifier? '(a))) +(test #f 'identifier (identifier? '#(a))) + +(test '(#t #f) + 'syntax + (macro:eval + '(let-syntax + ((foo + (transformer + (lambda (form env) + (capture-syntactic-environment + (lambda (transformer-env) + (identifier=? transformer-env 'x env 'x))))))) + (list (foo) + (let ((x 3)) + (foo)))))) + + +(test '(#f #t) + 'syntax + (macro:eval + '(let-syntax ((bar foo)) + (let-syntax + ((foo + (transformer + (lambda (form env) + (capture-syntactic-environment + (lambda (transformer-env) + (identifier=? transformer-env 'foo + env (cadr form)))))))) + (list (foo foo) + (foo bar)))))) + +(newline) +(cond ((null? errs) (display "Passed all tests")) + (else (display "errors were:") (newline) + (display "(got expected (call))") (newline) + (for-each (lambda (l) (write l) (newline)) errs))) +(newline) diff --git a/sierpinski.scm b/sierpinski.scm new file mode 100644 index 0000000..a4de2d6 --- /dev/null +++ b/sierpinski.scm @@ -0,0 +1,71 @@ +;"sierpinski.scm" Hash function for 2d data which preserves nearness. +;From: jjb@isye.gatech.edu (John Bartholdi) +; +; This code is in the public domain. + +;Date: Fri, 6 May 94 13:22:34 -0500 + +(define MAKE-SIERPINSKI-INDEXER + (lambda (max-coordinate) + (lambda (x y) + (if (not (and (<= 0 x max-coordinate) + (<= 0 y max-coordinate))) + (slib:error 'sierpinski-index + "Coordinate exceeds specified maximum.") + ; + ; The following two mutually recursive procedures + ; correspond to to partitioning successive triangles + ; into two sub-triangles, adjusting the index according + ; to which sub-triangle (x,y) lies in, then rescaling + ; and possibly rotating to continue the recursive + ; decomposition: + ; + (letrec ((loopA + (lambda (resolution x y index) + (cond ((zero? resolution) index) + (else + (let ((finer-index (+ index index))) + (if (> (+ x y) max-coordinate) + ; + ; In the upper sub-triangle: + (loopB resolution + (- max-coordinate y) + x + (+ 1 finer-index)) + ; + ; In the lower sub-triangle: + (loopB resolution + x + y + finer-index))))))) + (loopB + (lambda (resolution x y index) + (let ((new-x (+ x x)) + (new-y (+ y y)) + (finer-index (+ index index))) + (if (> new-y max-coordinate) + ; + ; In the upper sub-triangle: + (loopA (quotient resolution 2) + (- new-y max-coordinate) + (- max-coordinate new-x) + (+ finer-index 1)) + ; + ; In the lower sub-triangle: + (loopA (quotient resolution 2) + new-x + new-y + finer-index)))))) + (if (<= x y) + ; + ; Point in NW triangle of initial square: + (loopA max-coordinate + x + y + 0) + ; + ; Else point in SE triangle of initial square + ; so translate point and increase index: + (loopA max-coordinate + (- max-coordinate x) + (- max-coordinate y) 1))))))) diff --git a/slib.info b/slib.info new file mode 100644 index 0000000..d8ec637 --- /dev/null +++ b/slib.info @@ -0,0 +1,153 @@ +This is Info file slib.info, produced by Makeinfo-1.64 from the input +file slib.texi. + + This file documents SLIB, the portable Scheme library. + + Copyright (C) 1993 Todd R. Eigenschink Copyright (C) 1993, 1994, 1995 +Aubrey Jaffer + + Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + + Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + + Permission is granted to copy and distribute translations of this +manual into another language, under the above conditions for modified +versions, except that this permission notice may be stated in a +translation approved by the author. + + +Indirect: +slib.info-1: 885 +slib.info-2: 49910 +slib.info-3: 99287 +slib.info-4: 133361 +slib.info-5: 181826 +slib.info-6: 230781 +slib.info-7: 279927 +slib.info-8: 302856 + +Tag Table: +(Indirect) +Node: Top885 +Node: Overview1831 +Node: Installation2916 +Node: Porting4528 +Node: Coding Standards5779 +Node: Copyrights8112 +Node: Manual Conventions11415 +Node: Data Structures12091 +Node: Arrays12951 +Node: Array Mapping15895 +Node: Association Lists17170 +Node: Collections19428 +Node: Dynamic Data Type25543 +Node: Hash Tables26804 +Node: Hashing28921 +Node: Chapter Ordering33708 +Node: Object35324 +Node: Parameter lists43550 +Node: Priority Queues47932 +Node: Queues48784 +Node: Records49910 +Node: Base Table54316 +Node: Relational Database63453 +Node: Motivations64165 +Node: Creating and Opening Relational Databases69210 +Node: Relational Database Operations71642 +Node: Table Operations74439 +Node: Catalog Representation78947 +Node: Unresolved Issues81845 +Node: Database Utilities84776 +Node: Weight-Balanced Trees99287 +Node: Construction of Weight-Balanced Trees103174 +Node: Basic Operations on Weight-Balanced Trees106624 +Node: Advanced Operations on Weight-Balanced Trees109589 +Node: Indexing Operations on Weight-Balanced Trees115611 +Node: Structures119455 +Node: Macros120767 +Node: Defmacro121352 +Node: R4RS Macros123250 +Node: Macro by Example124479 +Node: Macros That Work127329 +Node: Syntactic Closures133361 +Node: Syntax-Case Macros150768 +Node: Fluid-Let154868 +Node: Yasos155783 +Node: Yasos terms156550 +Node: Yasos interface157574 +Node: Setters159657 +Node: Yasos examples162298 +Node: Numerics165226 +Node: Bit-Twiddling165640 +Node: Modular Arithmetic168832 +Node: Prime Testing and Generation170968 +Node: The Miller-Rabin Test173141 +Node: Prime Factorization177335 +Node: Random Numbers178615 +Node: Cyclic Checksum181826 +Node: Plotting183523 +Node: Root Finding186085 +Node: Procedures188902 +Node: Batch189767 +Node: Common List Functions197328 +Node: List construction197738 +Node: Lists as sets199401 +Node: Lists as sequences204394 +Node: Destructive list operations209056 +Node: Non-List functions211719 +Node: Format213067 +Node: Format Interface213264 +Node: Format Specification215001 +Node: Generic-Write224985 +Node: Line I/O226366 +Node: Multi-Processing227717 +Node: Object-To-String228558 +Node: Pretty-Print228824 +Node: Sorting230781 +Node: Topological Sort236554 +Node: Standard Formatted I/O238252 +Node: Standard Formatted Output238780 +Node: Standard Formatted Input247511 +Node: String-Case254170 +Node: String Ports254664 +Node: String Search255428 +Node: Tektronix Graphics Support256994 +Node: Tree Operations258385 +Node: Standards Support259911 +Node: With-File260605 +Node: Transcripts260881 +Node: Rev2 Procedures261202 +Node: Rev4 Optional Procedures262909 +Node: Multi-argument / and -263479 +Node: Multi-argument Apply264130 +Node: Rationalize264616 +Node: Promises265279 +Node: Dynamic-Wind265696 +Node: Values266952 +Node: Time267760 +Node: CLTime270664 +Node: Session Support272162 +Node: Repl273307 +Node: Quick Print274590 +Node: Debug275703 +Node: Breakpoints276345 +Node: Trace278563 +Node: Getopt279927 +Node: Command Line285745 +Node: System Interface288433 +Node: Require288933 +Node: Vicinity290924 +Node: Configuration293562 +Node: Input/Output295844 +Node: Legacy297444 +Node: System298163 +Node: Optional SLIB Packages300496 +Node: Procedure and Macro Index302856 +Node: Variable Index331571 + +End Tag Table diff --git a/slib.info-1 b/slib.info-1 new file mode 100644 index 0000000..89c4fce --- /dev/null +++ b/slib.info-1 @@ -0,0 +1,1306 @@ +This is Info file slib.info, produced by Makeinfo-1.64 from the input +file slib.texi. + + This file documents SLIB, the portable Scheme library. + + Copyright (C) 1993 Todd R. Eigenschink Copyright (C) 1993, 1994, 1995 +Aubrey Jaffer + + Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + + Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + + Permission is granted to copy and distribute translations of this +manual into another language, under the above conditions for modified +versions, except that this permission notice may be stated in a +translation approved by the author. + + +File: slib.info, Node: Top, Next: Overview, Prev: (dir), Up: (dir) + + This file documents SLIB, the portable Scheme library. + +Good Engineering is 1% inspiration and 99% documentation. +========================================================= + + Herein lies the good part. Many thanks to Todd Eigenschink + (who thanks Dave Love ) +for creating `slib.texi'. I have learned much from their example. + + Aubrey Jaffer jaffer@ai.mit.edu + +* Menu: + +* Overview:: What is SLIB? + +* Data Structures:: Various data structures. +* Macros:: Extensions to Scheme syntax. +* Numerics:: +* Procedures:: Miscellaneous utility procedures. +* Standards Support:: Support for Scheme Standards. +* Session Support:: Debugging, Pathnames, Require, etc. + +* Optional SLIB Packages:: +* Procedure and Macro Index:: +* Variable Index:: + + +File: slib.info, Node: Overview, Next: Data Structures, Prev: Top, Up: Top + +Overview +******** + + SLIB is a portable Scheme library meant to provide compatibility and +utility functions for all standard Scheme implementations, and fixes +several implementations which are non-conforming. SLIB conforms to +`Revised^4 Report on the Algorithmic Language Scheme' and the IEEE +P1178 specification. SLIB supports Unix and similar systems, VMS, and +MS-DOS. + + For a summary of what each file contains, see the file `README'. For +a list of the features that have changed since the last SLIB release, +see the file `ANNOUNCE'. For a list of the features that have changed +over time, see the file `ChangeLog'. + + The maintainer can be reached as `jaffer@ai.mit.edu'. + +* Menu: + +* Installation:: How to install SLIB on your system. +* Porting:: SLIB to new platforms +* Coding Standards:: How to write modules for SLIB. +* Copyrights:: Intellectual propery issues. +* Manual Conventions:: Conventions used in this manual. + + +File: slib.info, Node: Installation, Next: Porting, Prev: Overview, Up: Overview + +Installation +============ + + Check the manifest in `README' to find a configuration file for your +Scheme implementation. Initialization files for most IEEE P1178 +compliant Scheme Implementations are included with this distribution. + + If the Scheme implementation supports `getenv', then the value of the +shell environment variable SCHEME_LIBRARY_PATH will be used for +`(library-vicinity)' if it is defined. Currently, Chez, Elk, +MITScheme, scheme->c, VSCM, and SCM support `getenv'. + + You should check the definitions of `software-type', +`scheme-implementation-version', `implementation-vicinity', and +`library-vicinity' in the initialization file. There are comments in +the file for how to configure it. + + Once this is done you can modify the startup file for your Scheme +implementation to `load' this initialization file. SLIB is then +installed. + + Multiple implementations of Scheme can all use the same SLIB +directory. Simply configure each implementation's initialization file +as outlined above. + + The SCM implementation does not require any initialization file as +SLIB support is already built in to SCM. See the documentation with +SCM for installation instructions. + + SLIB includes methods to create heap images for the VSCM and Scheme48 +implementations. The instructions for creating a VSCM image are in +comments in `vscm.init'. To make a Scheme48 image, `cd' to the SLIB +directory and type `make slib48'. This will also create a shell script +with the name `slib48' which will invoke the saved image. + + +File: slib.info, Node: Porting, Next: Coding Standards, Prev: Installation, Up: Overview + +Porting +======= + + If there is no initialization file for your Scheme implementation, you +will have to create one. Your Scheme implementation must be largely +compliant with `IEEE Std 1178-1990' or `Revised^4 Report on the +Algorithmic Language Scheme' to support SLIB. + + `Template.scm' is an example configuration file. The comments inside +will direct you on how to customize it to reflect your system. Give +your new initialization file the implementation's name with `.init' +appended. For instance, if you were porting `foo-scheme' then the +initialization file might be called `foo.init'. + + Your customized version should then be loaded as part of your scheme +implementation's initialization. It will load `require.scm' (*Note +Require::) from the library; this will allow the use of `provide', +`provided?', and `require' along with the "vicinity" functions +(`vicinity' functions are documented in the section on Require. *Note +Require::). The rest of the library will then be accessible in a +system independent fashion. + + Please mail new working configuration files to `jaffer@ai.mit.edu' so +that they can be included in the SLIB distribution. + + +File: slib.info, Node: Coding Standards, Next: Copyrights, Prev: Porting, Up: Overview + +Coding Standards +================ + + All library packages are written in IEEE P1178 Scheme and assume that +a configuration file and `require.scm' package have already been +loaded. Other versions of Scheme can be supported in library packages +as well by using, for example, `(provided? 'rev3-report)' or `(require +'rev3-report)' (*Note Require::). + + `require.scm' defines `*catalog*', an association list of module +names and filenames. When a new package is added to the library, an +entry should be added to `require.scm'. Local packages can also be +added to `*catalog*' and even shadow entries already in the table. + + The module name and `:' should prefix each symbol defined in the +package. Definitions for external use should then be exported by having +`(define foo module-name:foo)'. + + Submitted code should not duplicate routines which are already in SLIB +files. Use `require' to force those features to be supported in your +package. Care should be taken that there are no circularities in the +`require's and `load's between the library packages. + + Documentation should be provided in Emacs Texinfo format if possible, +But documentation must be provided. + + Your package will be released sooner with SLIB if you send me a file +which tests your code. Please run this test *before* you send me the +code! + +Modifications +------------- + + Please document your changes. A line or two for `ChangeLog' is +sufficient for simple fixes or extensions. Look at the format of +`ChangeLog' to see what information is desired. Please send me `diff' +files from the latest SLIB distribution (remember to send `diff's of +`slib.texi' and `ChangeLog'). This makes for less email traffic and +makes it easier for me to integrate when more than one person is +changing a file (this happens a lot with `slib.texi' and `*.init' +files). + + If someone else wrote a package you want to significantly modify, +please try to contact the author, who may be working on a new version. +This will insure against wasting effort on obsolete versions. + + Please *do not* reformat the source code with your favorite +beautifier, make 10 fixes, and send me the resulting source code. I do +not have the time to fish through 10000 diffs to find your 10 real +fixes. + + +File: slib.info, Node: Copyrights, Next: Manual Conventions, Prev: Coding Standards, Up: Overview + +Copyrights +========== + + This section has instructions for SLIB authors regarding copyrights. + + Each package in SLIB must either be in the public domain, or come +with a statement of terms permitting users to copy, redistribute and +modify it. The comments at the beginning of `require.scm' and +`macwork.scm' illustrate copyright and appropriate terms. + + If your code or changes amount to less than about 10 lines, you do not +need to add your copyright or send a disclaimer. + +Putting code into the Public Domain +----------------------------------- + + In order to put code in the public domain you should sign a copyright +disclaimer and send it to the SLIB maintainer. Contact +jaffer@ai.mit.edu for the address to mail the disclaimer to. + + I, NAME, hereby affirm that I have placed the software package + NAME in the public domain. + + I affirm that I am the sole author and sole copyright holder for + the software package, that I have the right to place this software + package in the public domain, and that I will do nothing to + undermine this status in the future. + + SIGNATURE AND DATE + + This wording assumes that you are the sole author. If you are not the +sole author, the wording needs to be different. If you don't want to be +bothered with sending a letter every time you release or modify a +module, make your letter say that it also applies to your future +revisions of that module. + + Make sure no employer has any claim to the copyright on the work you +are submitting. If there is any doubt, create a copyright disclaimer +and have your employer sign it. Mail the signed disclaimer to the SLIB +maintainer. Contact jaffer@ai.mit.edu for the address to mail the +disclaimer to. An example disclaimer follows. + +Explicit copying terms +---------------------- + +If you submit more than about 10 lines of code which you are not placing +into the Public Domain (by sending me a disclaimer) you need to: + + * Arrange that your name appears in a copyright line for the + appropriate year. Multiple copyright lines are acceptable. + + * With your copyright line, specify any terms you require to be + different from those already in the file. + + * Make sure no employer has any claim to the copyright on the work + you are submitting. If there is any doubt, create a copyright + disclaimer and have your employer sign it. Mail the signed + disclaim to the SLIB maintainer. Contact jaffer@ai.mit.edu for + the address to mail the disclaimer to. + +Example: Company Copyright Disclaimer +------------------------------------- + + This disclaimer should be signed by a vice president or general +manager of the company. If you can't get at them, anyone else +authorized to license out software produced there will do. Here is a +sample wording: + + EMPLOYER Corporation hereby disclaims all copyright interest in + the program PROGRAM written by NAME. + + EMPLOYER Corporation affirms that it has no other intellectual + property interest that would undermine this release, and will do + nothing to undermine it in the future. + + SIGNATURE AND DATE, + NAME, TITLE, EMPLOYER Corporation + + +File: slib.info, Node: Manual Conventions, Prev: Copyrights, Up: Overview + +Manual Conventions +================== + + Things that are labeled as Functions are called for their return +values. Things that are labeled as Procedures are called primarily for +their side effects. + + All examples throughout this text were produced using the `scm' +Scheme implementation. + + At the beginning of each section, there is a line that looks something +like + + `(require 'feature)'. + +This means that, in order to use `feature', you must include the line +`(require 'feature)' somewhere in your code prior to the use of that +feature. `require' will make sure that the feature is loaded. + + +File: slib.info, Node: Data Structures, Next: Macros, Prev: Overview, Up: Top + +Data Structures +*************** + +* Menu: + +* Arrays:: 'array +* Array Mapping:: 'array-for-each +* Association Lists:: 'alist +* Collections:: 'collect +* Dynamic Data Type:: 'dynamic +* Hash Tables:: 'hash-table +* Hashing:: 'hash, 'sierpinski, 'soundex +* Chapter Ordering:: 'chapter-order +* Object:: 'object +* Parameter lists:: 'parameters +* Priority Queues:: 'priority-queue +* Queues:: 'queue +* Records:: 'record +* Base Table:: +* Relational Database:: 'relational-database +* Weight-Balanced Trees:: 'wt-tree +* Structures:: 'struct, 'structure + + +File: slib.info, Node: Arrays, Next: Array Mapping, Prev: Data Structures, Up: Data Structures + +Arrays +====== + + `(require 'array)' + + - Function: array? OBJ + Returns `#t' if the OBJ is an array, and `#f' if not. + + - Function: make-array INITIAL-VALUE BOUND1 BOUND2 ... + Creates and returns an array that has as many dimensins as there + are BOUNDs and fills it with INITIAL-VALUE. + + When constructing an array, BOUND is either an inclusive range of +indices expressed as a two element list, or an upper bound expressed as +a single integer. So + (make-array 'foo 3 3) == (make-array 'foo '(0 2) '(0 2)) + + - Function: make-shared-array ARRAY MAPPER BOUND1 BOUND2 ... + `make-shared-array' can be used to create shared subarrays of other + arrays. The MAPPER is a function that translates coordinates in + the new array into coordinates in the old array. A MAPPER must be + linear, and its range must stay within the bounds of the old + array, but it can be otherwise arbitrary. A simple example: + (define fred (make-array #f 8 8)) + (define freds-diagonal + (make-shared-array fred (lambda (i) (list i i)) 8)) + (array-set! freds-diagonal 'foo 3) + (array-ref fred 3 3) + => FOO + (define freds-center + (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) + 2 2)) + (array-ref freds-center 0 0) + => FOO + + - Function: array-rank OBJ + Returns the number of dimensions of OBJ. If OBJ is not an array, + 0 is returned. + + - Function: array-shape ARRAY + `array-shape' returns a list of inclusive bounds. So: + (array-shape (make-array 'foo 3 5)) + => ((0 2) (0 4)) + + - Function: array-dimensions ARRAY + `array-dimensions' is similar to `array-shape' but replaces + elements with a 0 minimum with one greater than the maximum. So: + (array-dimensions (make-array 'foo 3 5)) + => (3 5) + + - Procedure: array-in-bounds? ARRAY INDEX1 INDEX2 ... + Returns `#t' if its arguments would be acceptable to `array-ref'. + + - Function: array-ref ARRAY INDEX1 INDEX2 ... + Returns the element at the `(INDEX1, INDEX2)' element in ARRAY. + + - Procedure: array-set! ARRAY NEW-VALUE INDEX1 INDEX2 ... + + - Function: array-1d-ref ARRAY INDEX + - Function: array-2d-ref ARRAY INDEX INDEX + - Function: array-3d-ref ARRAY INDEX INDEX INDEX + + - Procedure: array-1d-set! ARRAY NEW-VALUE INDEX + - Procedure: array-2d-set! ARRAY NEW-VALUE INDEX INDEX + - Procedure: array-3d-set! ARRAY NEW-VALUE INDEX INDEX INDEX + + The functions are just fast versions of `array-ref' and `array-set!' +that take a fixed number of arguments, and perform no bounds checking. + + If you comment out the bounds checking code, this is about as +efficient as you could ask for without help from the compiler. + + An exercise left to the reader: implement the rest of APL. + + +File: slib.info, Node: Array Mapping, Next: Association Lists, Prev: Arrays, Up: Data Structures + +Array Mapping +============= + + `(require 'array-for-each)' + + - Function: array-map! ARRAY0 PROC ARRAY1 ... + ARRAY1, ... must have the same number of dimensions as ARRAY0 and + have a range for each index which includes the range for the + corresponding index in ARRAY0. PROC is applied to each tuple of + elements of ARRAY1 ... and the result is stored as the + corresponding element in ARRAY0. The value returned is + unspecified. The order of application is unspecified. + + - Function: array-for-each PROC ARRAY0 ... + PROC is applied to each tuple of elements of ARRAY0 ... in + row-major order. The value returned is unspecified. + + - Function: array-indexes ARRAY + Returns an array of lists of indexes for ARRAY such that, if LI is + a list of indexes for which ARRAY is defined, (equal? LI (apply + array-ref (array-indexes ARRAY) LI)). + + - Function: array-copy! SOURCE DESTINATION + Copies every element from vector or array SOURCE to the + corresponding element of DESTINATION. DESTINATION must have the + same rank as SOURCE, and be at least as large in each dimension. + The order of copying is unspecified. + + +File: slib.info, Node: Association Lists, Next: Collections, Prev: Array Mapping, Up: Data Structures + +Association Lists +================= + + `(require 'alist)' + + Alist functions provide utilities for treating a list of key-value +pairs as an associative database. These functions take an equality +predicate, PRED, as an argument. This predicate should be repeatable, +symmetric, and transitive. + + Alist functions can be used with a secondary index method such as hash +tables for improved performance. + + - Function: predicate->asso PRED + Returns an "association function" (like `assq', `assv', or + `assoc') corresponding to PRED. The returned function returns a + key-value pair whose key is `pred'-equal to its first argument or + `#f' if no key in the alist is PRED-equal to the first argument. + + - Function: alist-inquirer PRED + Returns a procedure of 2 arguments, ALIST and KEY, which returns + the value associated with KEY in ALIST or `#f' if KEY does not + appear in ALIST. + + - Function: alist-associator PRED + Returns a procedure of 3 arguments, ALIST, KEY, and VALUE, which + returns an alist with KEY and VALUE associated. Any previous + value associated with KEY will be lost. This returned procedure + may or may not have side effects on its ALIST argument. An + example of correct usage is: + (define put (alist-associator string-ci=?)) + (define alist '()) + (set! alist (put alist "Foo" 9)) + + - Function: alist-remover PRED + Returns a procedure of 2 arguments, ALIST and KEY, which returns + an alist with an association whose KEY is key removed. This + returned procedure may or may not have side effects on its ALIST + argument. An example of correct usage is: + (define rem (alist-remover string-ci=?)) + (set! alist (rem alist "foo")) + + - Function: alist-map PROC ALIST + Returns a new association list formed by mapping PROC over the + keys and values of ALIST. PROC must be a function of 2 arguments + which returns the new value part. + + - Function: alist-for-each PROC ALIST + Applies PROC to each pair of keys and values of ALIST. PROC must + be a function of 2 arguments. The returned value is unspecified. + + +File: slib.info, Node: Collections, Next: Dynamic Data Type, Prev: Association Lists, Up: Data Structures + +Collections +=========== + + `(require 'collect)' + + Routines for managing collections. Collections are aggregate data +structures supporting iteration over their elements, similar to the +Dylan(TM) language, but with a different interface. They have +"elements" indexed by corresponding "keys", although the keys may be +implicit (as with lists). + + New types of collections may be defined as YASOS objects (*Note +Yasos::). They must support the following operations: + * `(collection? SELF)' (always returns `#t'); + + * `(size SELF)' returns the number of elements in the collection; + + * `(print SELF PORT)' is a specialized print operation for the + collection which prints a suitable representation on the given + PORT or returns it as a string if PORT is `#t'; + + * `(gen-elts SELF)' returns a thunk which on successive invocations + yields elements of SELF in order or gives an error if it is + invoked more than `(size SELF)' times; + + * `(gen-keys SELF)' is like `gen-elts', but yields the collection's + keys in order. + + They might support specialized `for-each-key' and `for-each-elt' +operations. + + - Function: collection? OBJ + A predicate, true initially of lists, vectors and strings. New + sorts of collections must answer `#t' to `collection?'. + + - Procedure: map-elts PROC . COLLECTIONS + - Procedure: do-elts PROC . COLLECTIONS + PROC is a procedure taking as many arguments as there are + COLLECTIONS (at least one). The COLLECTIONS are iterated over in + their natural order and PROC is applied to the elements yielded by + each iteration in turn. The order in which the arguments are + supplied corresponds to te order in which the COLLECTIONS appear. + `do-elts' is used when only side-effects of PROC are of interest + and its return value is unspecified. `map-elts' returns a + collection (actually a vector) of the results of the applications + of PROC. + + Example: + (map-elts + (list 1 2 3) (vector 1 2 3)) + => #(2 4 6) + + - Procedure: map-keys PROC . COLLECTIONS + - Procedure: do-keys PROC . COLLECTIONS + These are analogous to `map-elts' and `do-elts', but each + iteration is over the COLLECTIONS' *keys* rather than their + elements. + + Example: + (map-keys + (list 1 2 3) (vector 1 2 3)) + => #(0 2 4) + + - Procedure: for-each-key COLLECTION PROC + - Procedure: for-each-elt COLLECTION PROC + These are like `do-keys' and `do-elts' but only for a single + collection; they are potentially more efficient. + + - Function: reduce PROC SEED . COLLECTIONS + A generalization of the list-based `comlist:reduce-init' (*Note + Lists as sequences::) to collections which will shadow the + list-based version if `(require 'collect)' follows `(require + 'common-list-functions)' (*Note Common List Functions::). + + Examples: + (reduce + 0 (vector 1 2 3)) + => 6 + (reduce union '() '((a b c) (b c d) (d a))) + => (c b d a). + + - Function: any? PRED . COLLECTIONS + A generalization of the list-based `some' (*Note Lists as + sequences::) to collections. + + Example: + (any? odd? (list 2 3 4 5)) + => #t + + - Function: every? PRED . COLLECTIONS + A generalization of the list-based `every' (*Note Lists as + sequences::) to collections. + + Example: + (every? collection? '((1 2) #(1 2))) + => #t + + - Function: empty? COLLECTION + Returns `#t' iff there are no elements in COLLECTION. + + `(empty? COLLECTION) == (zero? (size COLLECTION))' + + - Function: size COLLECTION + Returns the number of elements in COLLECTION. + + - Function: Setter LIST-REF + See *Note Setters:: for a definition of "setter". N.B. `(setter + list-ref)' doesn't work properly for element 0 of a list. + + Here is a sample collection: `simple-table' which is also a `table'. + (define-predicate TABLE?) + (define-operation (LOOKUP table key failure-object)) + (define-operation (ASSOCIATE! table key value)) ;; returns key + (define-operation (REMOVE! table key)) ;; returns value + + (define (MAKE-SIMPLE-TABLE) + (let ( (table (list)) ) + (object + ;; table behaviors + ((TABLE? self) #t) + ((SIZE self) (size table)) + ((PRINT self port) (format port "#")) + ((LOOKUP self key failure-object) + (cond + ((assq key table) => cdr) + (else failure-object) + )) + ((ASSOCIATE! self key value) + (cond + ((assq key table) + => (lambda (bucket) (set-cdr! bucket value) key)) + (else + (set! table (cons (cons key value) table)) + key) + )) + ((REMOVE! self key);; returns old value + (cond + ((null? table) (slib:error "TABLE:REMOVE! Key not found: " key)) + ((eq? key (caar table)) + (let ( (value (cdar table)) ) + (set! table (cdr table)) + value) + ) + (else + (let loop ( (last table) (this (cdr table)) ) + (cond + ((null? this) + (slib:error "TABLE:REMOVE! Key not found: " key)) + ((eq? key (caar this)) + (let ( (value (cdar this)) ) + (set-cdr! last (cdr this)) + value) + ) + (else + (loop (cdr last) (cdr this))) + ) ) ) + )) + ;; collection behaviors + ((COLLECTION? self) #t) + ((GEN-KEYS self) (collect:list-gen-elts (map car table))) + ((GEN-ELTS self) (collect:list-gen-elts (map cdr table))) + ((FOR-EACH-KEY self proc) + (for-each (lambda (bucket) (proc (car bucket))) table) + ) + ((FOR-EACH-ELT self proc) + (for-each (lambda (bucket) (proc (cdr bucket))) table) + ) + ) ) ) + + +File: slib.info, Node: Dynamic Data Type, Next: Hash Tables, Prev: Collections, Up: Data Structures + +Dynamic Data Type +================= + + `(require 'dynamic)' + + - Function: make-dynamic OBJ + Create and returns a new "dynamic" whose global value is OBJ. + + - Function: dynamic? OBJ + Returns true if and only if OBJ is a dynamic. No object + satisfying `dynamic?' satisfies any of the other standard type + predicates. + + - Function: dynamic-ref DYN + Return the value of the given dynamic in the current dynamic + environment. + + - Procedure: dynamic-set! DYN OBJ + Change the value of the given dynamic to OBJ in the current + dynamic environment. The returned value is unspecified. + + - Function: call-with-dynamic-binding DYN OBJ THUNK + Invoke and return the value of the given thunk in a new, nested + dynamic environment in which the given dynamic has been bound to a + new location whose initial contents are the value OBJ. This + dynamic environment has precisely the same extent as the + invocation of the thunk and is thus captured by continuations + created within that invocation and re-established by those + continuations when they are invoked. + + The `dynamic-bind' macro is not implemented. + + +File: slib.info, Node: Hash Tables, Next: Hashing, Prev: Dynamic Data Type, Up: Data Structures + +Hash Tables +=========== + + `(require 'hash-table)' + + - Function: predicate->hash PRED + Returns a hash function (like `hashq', `hashv', or `hash') + corresponding to the equality predicate PRED. PRED should be + `eq?', `eqv?', `equal?', `=', `char=?', `char-ci=?', `string=?', or + `string-ci=?'. + + A hash table is a vector of association lists. + + - Function: make-hash-table K + Returns a vector of K empty (association) lists. + + Hash table functions provide utilities for an associative database. +These functions take an equality predicate, PRED, as an argument. PRED +should be `eq?', `eqv?', `equal?', `=', `char=?', `char-ci=?', +`string=?', or `string-ci=?'. + + - Function: predicate->hash-asso PRED + Returns a hash association function of 2 arguments, KEY and + HASHTAB, corresponding to PRED. The returned function returns a + key-value pair whose key is PRED-equal to its first argument or + `#f' if no key in HASHTAB is PRED-equal to the first argument. + + - Function: hash-inquirer PRED + Returns a procedure of 3 arguments, `hashtab' and `key', which + returns the value associated with `key' in `hashtab' or `#f' if + key does not appear in `hashtab'. + + - Function: hash-associator PRED + Returns a procedure of 3 arguments, HASHTAB, KEY, and VALUE, which + modifies HASHTAB so that KEY and VALUE associated. Any previous + value associated with KEY will be lost. + + - Function: hash-remover PRED + Returns a procedure of 2 arguments, HASHTAB and KEY, which + modifies HASHTAB so that the association whose key is KEY is + removed. + + - Function: hash-map PROC HASH-TABLE + Returns a new hash table formed by mapping PROC over the keys and + values of HASH-TABLE. PROC must be a function of 2 arguments + which returns the new value part. + + - Function: hash-for-each PROC HASH-TABLE + Applies PROC to each pair of keys and values of HASH-TABLE. PROC + must be a function of 2 arguments. The returned value is + unspecified. + + +File: slib.info, Node: Hashing, Next: Chapter Ordering, Prev: Hash Tables, Up: Data Structures + +Hashing +======= + + `(require 'hash)' + + These hashing functions are for use in quickly classifying objects. +Hash tables use these functions. + + - Function: hashq OBJ K + - Function: hashv OBJ K + - Function: hash OBJ K + Returns an exact non-negative integer less than K. For each + non-negative integer less than K there are arguments OBJ for which + the hashing functions applied to OBJ and K returns that integer. + + For `hashq', `(eq? obj1 obj2)' implies `(= (hashq obj1 k) (hashq + obj2))'. + + For `hashv', `(eqv? obj1 obj2)' implies `(= (hashv obj1 k) (hashv + obj2))'. + + For `hash', `(equal? obj1 obj2)' implies `(= (hash obj1 k) (hash + obj2))'. + + `hash', `hashv', and `hashq' return in time bounded by a constant. + Notice that items having the same `hash' implies the items have + the same `hashv' implies the items have the same `hashq'. + + `(require 'sierpinski)' + + - Function: make-sierpinski-indexer MAX-COORDINATE + Returns a procedure (eg hash-function) of 2 numeric arguments which + preserves *nearness* in its mapping from NxN to N. + + MAX-COORDINATE is the maximum coordinate (a positive integer) of a + population of points. The returned procedures is a function that + takes the x and y coordinates of a point, (non-negative integers) + and returns an integer corresponding to the relative position of + that point along a Sierpinski curve. (You can think of this as + computing a (pseudo-) inverse of the Sierpinski spacefilling + curve.) + + Example use: Make an indexer (hash-function) for integer points + lying in square of integer grid points [0,99]x[0,99]: + (define space-key (make-sierpinski-indexer 100)) + Now let's compute the index of some points: + (space-key 24 78) => 9206 + (space-key 23 80) => 9172 + + Note that locations (24, 78) and (23, 80) are near in index and + therefore, because the Sierpinski spacefilling curve is + continuous, we know they must also be near in the plane. Nearness + in the plane does not, however, necessarily correspond to nearness + in index, although it *tends* to be so. + + Example applications: + + Sort points by Sierpinski index to get heuristic solution to + *travelling salesman problem*. For details of performance, + see L. Platzman and J. Bartholdi, "Spacefilling curves and the + Euclidean travelling salesman problem", JACM 36(4):719-737 + (October 1989) and references therein. + + + Use Sierpinski index as key by which to store 2-dimensional + data in a 1-dimensional data structure (such as a table). + Then locations that are near each other in 2-d space will + tend to be near each other in 1-d data structure; and + locations that are near in 1-d data structure will be near in + 2-d space. This can significantly speed retrieval from + secondary storage because contiguous regions in the plane + will tend to correspond to contiguous regions in secondary + storage. (This is a standard technique for managing CAD/CAM + or geographic data.) + + + `(require 'soundex)' + + - Function: soundex NAME + Computes the *soundex* hash of NAME. Returns a string of an + initial letter and up to three digits between 0 and 6. Soundex + supposedly has the property that names that sound similar in normal + English pronunciation tend to map to the same key. + + Soundex was a classic algorithm used for manual filing of personal + records before the advent of computers. It performs adequately for + English names but has trouble with other nationalities. + + See Knuth, Vol. 3 `Sorting and searching', pp 391-2 + + To manage unusual inputs, `soundex' omits all non-alphabetic + characters. Consequently, in this implementation: + + (soundex ) => "" + (soundex "") => "" + + Examples from Knuth: + + (map soundex '("Euler" "Gauss" "Hilbert" "Knuth" + "Lloyd" "Lukasiewicz")) + => ("E460" "G200" "H416" "K530" "L300" "L222") + + (map soundex '("Ellery" "Ghosh" "Heilbronn" "Kant" + "Ladd" "Lissajous")) + => ("E460" "G200" "H416" "K530" "L300" "L222") + + Some cases in which the algorithm fails (Knuth): + + (map soundex '("Rogers" "Rodgers")) => ("R262" "R326") + + (map soundex '("Sinclair" "St. Clair")) => ("S524" "S324") + + (map soundex '("Tchebysheff" "Chebyshev")) => ("T212" "C121") + + +File: slib.info, Node: Chapter Ordering, Next: Object, Prev: Hashing, Up: Data Structures + +Chapter Ordering +================ + + `(require 'chapter-order)' + + The `chap:' functions deal with strings which are ordered like +chapter numbers (or letters) in a book. Each section of the string +consists of consecutive numeric or consecutive aphabetic characters of +like case. + + - Function: chap:string #t + (chap:string #t + (chap:string #t + + - Function: chap:string>? STRING1 STRING2 + - Function: chap:string<=? STRING1 STRING2 + - Function: chap:string>=? STRING1 STRING2 + Implement the corresponding chapter-order predicates. + + - Function: chap:next-string STRING + Returns the next string in the *chapter order*. If STRING has no + alphabetic or numeric characters, `(string-append STRING "0")' is + returnd. The argument to chap:next-string will always be + `chap:string "a.10" + (chap:next-string "4c") => "4d" + (chap:next-string "4z") => "4aa" + (chap:next-string "Revised^{4}") => "Revised^{5}" + + +File: slib.info, Node: Object, Next: Parameter lists, Prev: Chapter Ordering, Up: Data Structures + +Macroless Object System +======================= + + `(require 'object)' + + This is the Macroless Object System written by Wade Humeniuk +(whumeniu@datap.ca). Conceptual Tributes: *Note Yasos::, MacScheme's +%object, CLOS, Lack of R4RS macros. + +Concepts +-------- + +OBJECT + An object is an ordered association-list (by `eq?') of methods + (procedures). Methods can be added (`make-method!'), deleted + (`unmake-method!') and retrieved (`get-method'). Objects may + inherit methods from other objects. The object binds to the + environment it was created in, allowing closures to be used to + hide private procedures and data. + +GENERIC-METHOD + A generic-method associates (in terms of `eq?') object's method. + This allows scheme function style to be used for objects. The + calling scheme for using a generic method is `(generic-method + object param1 param2 ...)'. + +METHOD + A method is a procedure that exists in the object. To use a method + get-method must be called to look-up the method. Generic methods + implement the get-method functionality. Methods may be added to an + object associated with any scheme obj in terms of eq? + +GENERIC-PREDICATE + A generic method that returns a boolean value for any scheme obj. + +PREDICATE + A object's method asscociated with a generic-predicate. Returns + `#t'. + +Procedures +---------- + + - Function: make-object ANCESTOR ... + Returns an object. Current object implementation is a tagged + vector. ANCESTORs are optional and must be objects in terms of + object?. ANCESTORs methods are included in the object. Multiple + ANCESTORs might associate the same generic-method with a method. + In this case the method of the ANCESTOR first appearing in the + list is the one returned by `get-method'. + + - Function: object? OBJ + Returns boolean value whether OBJ was created by make-object. + + - Function: make-generic-method EXCEPTION-PROCEDURE + Returns a procedure which be associated with an object's methods. + If EXCEPTION-PROCEDURE is specified then it is used to process + non-objects. + + - Function: make-generic-predicate + Returns a boolean procedure for any scheme object. + + - Function: make-method! OBJECT GENERIC-METHOD METHOD + Associates METHOD to the GENERIC-METHOD in the object. The METHOD + overrides any previous association with the GENERIC-METHOD within + the object. Using `unmake-method!' will restore the object's + previous association with the GENERIC-METHOD. METHOD must be a + procedure. + + - Function: make-predicate! OBJECT GENERIC-PRECIATE + Makes a predicate method associated with the GENERIC-PREDICATE. + + - Function: unmake-method! OBJECT GENERIC-METHOD + Removes an object's association with a GENERIC-METHOD . + + - Function: get-method OBJECT GENERIC-METHOD + Returns the object's method associated (if any) with the + GENERIC-METHOD. If no associated method exists an error is + flagged. + +Examples +-------- + + (require 'object) + + (define instantiate (make-generic-method)) + + (define (make-instance-object . ancestors) + (define self (apply make-object + (map (lambda (obj) (instantiate obj)) ancestors))) + (make-method! self instantiate (lambda (self) self)) + self) + + (define who (make-generic-method)) + (define imigrate! (make-generic-method)) + (define emigrate! (make-generic-method)) + (define describe (make-generic-method)) + (define name (make-generic-method)) + (define address (make-generic-method)) + (define members (make-generic-method)) + + (define society + (let () + (define self (make-instance-object)) + (define population '()) + (make-method! self imigrate! + (lambda (new-person) + (if (not (eq? new-person self)) + (set! population (cons new-person population))))) + (make-method! self emigrate! + (lambda (person) + (if (not (eq? person self)) + (set! population + (comlist:remove-if (lambda (member) + (eq? member person)) + population))))) + (make-method! self describe + (lambda (self) + (map (lambda (person) (describe person)) population))) + (make-method! self who + (lambda (self) (map (lambda (person) (name person)) + population))) + (make-method! self members (lambda (self) population)) + self)) + + (define (make-person %name %address) + (define self (make-instance-object society)) + (make-method! self name (lambda (self) %name)) + (make-method! self address (lambda (self) %address)) + (make-method! self who (lambda (self) (name self))) + (make-method! self instantiate + (lambda (self) + (make-person (string-append (name self) "-son-of") + %address))) + (make-method! self describe + (lambda (self) (list (name self) (address self)))) + (imigrate! self) + self) + +Inverter Documentation +...................... + + Inheritance: + ::( ) + Generic-methods + ::value => ::value + ::set-value! => ::set-value! + ::describe => ::describe + ::help + ::invert + ::inverter? + +Number Documention +.................. + + Inheritance + ::() + Slots + :: + Generic Methods + ::value + ::set-value! + +Inverter code +............. + + (require 'object) + + (define value (make-generic-method (lambda (val) val))) + (define set-value! (make-generic-method)) + (define invert (make-generic-method + (lambda (val) + (if (number? val) + (/ 1 val) + (error "Method not supported:" val))))) + (define noop (make-generic-method)) + (define inverter? (make-generic-predicate)) + (define describe (make-generic-method)) + (define help (make-generic-method)) + + (define (make-number x) + (define self (make-object)) + (make-method! self value (lambda (this) x)) + (make-method! self set-value! + (lambda (this new-value) (set! x new-value))) + self) + + (define (make-description str) + (define self (make-object)) + (make-method! self describe (lambda (this) str)) + (make-method! self help (lambda (this) "Help not available")) + self) + + (define (make-inverter) + (define self (make-object + (make-number 1) + (make-description "A number which can be inverted"))) + (define (get-method self value)) + (make-method! self invert (lambda (self) (/ 1 ( self)))) + (make-predicate! self inverter?) + (unmake-method! self help) + (make-method! self help + (lambda (self) + (display "Inverter Methods:") (newline) + (display " (value inverter) ==> n") (newline))) + self) + + ;;;; Try it out + + (define invert! (make-generic-method)) + + (define x (make-inverter)) + + (make-method! x invert! (lambda () (set-value! x (/ 1 (value x))))) + + (value x) => 1 + (set-value! x 33) => undefined + (invert! x) => undefined + (value x) => 1/33 + + (unmake-method! x invert!) => undefined + + (invert! x) error--> ERROR: Method not supported: x + + +File: slib.info, Node: Parameter lists, Next: Priority Queues, Prev: Object, Up: Data Structures + +Parameter lists +=============== + + `(require 'parameters)' + +Arguments to procedures in scheme are distinguished from each other by +their position in the procedure call. This can be confusing when a +procedure takes many arguments, many of which are not often used. + +A "parameter-list" is a way of passing named information to a +procedure. Procedures are also defined to set unused parameters to +default values, check parameters, and combine parameter lists. + +A PARAMETER has the form `(parameter-name value1 ...)'. This format +allows for more than one value per parameter-name. + +A PARAMETER-LIST is a list of PARAMETERs, each with a different +PARAMETER-NAME. + + - Function: make-parameter-list PARAMETER-NAMES + Returns an empty parameter-list with slots for PARAMETER-NAMES. + + - Function: parameter-list-ref PARAMETER-LIST PARAMETER-NAME + PARAMETER-NAME must name a valid slot of PARAMETER-LIST. + `parameter-list-ref' returns the value of parameter PARAMETER-NAME + of PARAMETER-LIST. + + - Procedure: adjoin-parameters! PARAMETER-LIST PARAMETER1 ... + Returns PARAMETER-LIST with PARAMETER1 ... merged in. + + - Procedure: parameter-list-expand EXPANDERS PARAMETER-LIST + EXPANDERS is a list of procedures whose order matches the order of + the PARAMETER-NAMEs in the call to `make-parameter-list' which + created PARAMETER-LIST. For each non-false element of EXPANDERS + that procedure is mapped over the corresponding parameter value + and the returned parameter lists are merged into PARAMETER-LIST. + + This process is repeated until PARAMETER-LIST stops growing. The + value returned from `parameter-list-expand' is unspecified. + + - Function: fill-empty-parameters DEFAULTS PARAMETER-LIST + DEFAULTS is a list of lists whose order matches the order of the + PARAMETER-NAMEs in the call to `make-parameter-list' which created + PARAMETER-LIST. `fill-empty-parameters' returns a new + parameter-list with each empty parameter filled with the + corresponding DEFAULT. + + - Function: check-parameters CHECKS PARAMETER-LIST + CHECKS is a list of procedures whose order matches the order of + the PARAMETER-NAMEs in the call to `make-parameter-list' which + created PARAMETER-LIST. + + `check-parameters' returns PARAMETER-LIST if each CHECK of the + corresponding PARAMETER-LIST returns non-false. If some CHECK + returns `#f' an error is signaled. + +In the following procedures ARITIES is a list of symbols. The elements +of `arities' can be: + +`single' + Requires a single parameter. + +`optional' + A single parameter or no parameter is acceptable. + +`boolean' + A single boolean parameter or zero parameters is acceptable. + +`nary' + Any number of parameters are acceptable. + +`nary1' + One or more of parameters are acceptable. + + - Function: parameter-list->arglist POSITIONS ARITIES TYPES + PARAMETER-LIST + Returns PARAMETER-LIST converted to an argument list. Parameters + of ARITY type `single' and `boolean' are converted to the single + value associated with them. The other ARITY types are converted + to lists of the value(s) of type TYPES. + + POSITIONS is a list of positive integers whose order matches the + order of the PARAMETER-NAMEs in the call to `make-parameter-list' + which created PARAMETER-LIST. The integers specify in which + argument position the corresponding parameter should appear. + + - Function: getopt->parameter-list ARGC ARGV OPTNAMES ARITIES TYPES + ALIASES + Returns ARGV converted to a parameter-list. OPTNAMES are the + parameter-names. ALIASES is a list of lists of strings and + elements of OPTNAMES. Each of these strings which have length of + 1 will be treated as a single - option by `getopt'. Longer + strings will be treated as long-named options (*note getopt-: + Getopt.). + + - Function: getopt->arglist ARGC ARGV OPTNAMES POSITIONS ARITIES TYPES + DEFAULTS CHECKS ALIASES + Like `getopt->parameter-list', but converts ARGV to an + argument-list as specified by OPTNAMES, POSITIONS, ARITIES, TYPES, + DEFAULTS, CHECKS, and ALIASES. + + These `getopt' functions can be used with SLIB relational databases. +For an example, *Note make-command-server: Database Utilities. + + +File: slib.info, Node: Priority Queues, Next: Queues, Prev: Parameter lists, Up: Data Structures + +Priority Queues +=============== + + `(require 'priority-queue)' + + - Function: make-heap PRED *a procedure* + (define foo (alist-table 'foo)) + foo => #f + + - Function: make-base FILENAME KEY-DIMENSION COLUMN-TYPES + Returns a new, open, low-level database (collection of tables) + associated with FILENAME. This returned database has an empty + table associated with CATALOG-ID. The positive integer + KEY-DIMENSION is the number of keys composed to make a PRIMARY-KEY + for the catalog table. The list of symbols COLUMN-TYPES describes + the types of each column for that table. If the database cannot + be created as specified, `#f' is returned. + + Calling the `close-base' method on this database and possibly other + operations will cause FILENAME to be written to. If FILENAME is + `#f' a temporary, non-disk based database will be created if such + can be supported by the base table implelentation. + + - Function: open-base FILENAME MUTABLE + Returns an open low-level database associated with FILENAME. If + MUTABLE? is `#t', this database will have methods capable of + effecting change to the database. If MUTABLE? is `#f', only + methods for inquiring the database will be available. If the + database cannot be opened as specified `#f' is returned. + + Calling the `close-base' (and possibly other) method on a MUTABLE? + database will cause FILENAME to be written to. + + - Function: write-base LLDB FILENAME + Causes the low-level database LLDB to be written to FILENAME. If + the write is successful, also causes LLDB to henceforth be + associated with FILENAME. Calling the `close-database' (and + possibly other) method on LLDB may cause FILENAME to be written + to. If FILENAME is `#f' this database will be changed to a + temporary, non-disk based database if such can be supported by the + underlying base table implelentation. If the operations completed + successfully, `#t' is returned. Otherwise, `#f' is returned. + + - Function: sync-base LLDB + Causes the file associated with the low-level database LLDB to be + updated to reflect its current state. If the associated filename + is `#f', no action is taken and `#f' is returned. If this + operation completes successfully, `#t' is returned. Otherwise, + `#f' is returned. + + - Function: close-base LLDB + Causes the low-level database LLDB to be written to its associated + file (if any). If the write is successful, subsequent operations + to LLDB will signal an error. If the operations complete + successfully, `#t' is returned. Otherwise, `#f' is returned. + + - Function: make-table LLDB KEY-DIMENSION COLUMN-TYPES + Returns the BASE-ID for a new base table, otherwise returns `#f'. + The base table can then be opened using `(open-table LLDB + BASE-ID)'. The positive integer KEY-DIMENSION is the number of + keys composed to make a PRIMARY-KEY for this table. The list of + symbols COLUMN-TYPES describes the types of each column. + + - Constant: catalog-id + A constant BASE-ID suitable for passing as a parameter to + `open-table'. CATALOG-ID will be used as the base table for the + system catalog. + + - Function: open-table LLDB BASE-ID KEY-DIMENSION COLUMN-TYPES + Returns a HANDLE for an existing base table in the low-level + database LLDB if that table exists and can be opened in the mode + indicated by MUTABLE?, otherwise returns `#f'. + + As with `make-table', the positive integer KEY-DIMENSION is the + number of keys composed to make a PRIMARY-KEY for this table. The + list of symbols COLUMN-TYPES describes the types of each column. + + - Function: kill-table LLDB BASE-ID KEY-DIMENSION COLUMN-TYPES + Returns `#t' if the base table associated with BASE-ID was removed + from the low level database LLDB, and `#f' otherwise. + + - Function: make-keyifier-1 TYPE + Returns a procedure which accepts a single argument which must be + of type TYPE. This returned procedure returns an object suitable + for being a KEY argument in the functions whose descriptions + follow. + + Any 2 arguments of the supported type passed to the returned + function which are not `equal?' must result in returned values + which are not `equal?'. + + - Function: make-list-keyifier KEY-DIMENSION TYPES + The list of symbols TYPES must have at least KEY-DIMENSION + elements. Returns a procedure which accepts a list of length + KEY-DIMENSION and whose types must corresopond to the types named + by TYPES. This returned procedure combines the elements of its + list argument into an object suitable for being a KEY argument in + the functions whose descriptions follow. + + Any 2 lists of supported types (which must at least include + symbols and non-negative integers) passed to the returned function + which are not `equal?' must result in returned values which are not + `equal?'. + + - Function: make-key-extractor KEY-DIMENSION TYPES COLUMN-NUMBER + Returns a procedure which accepts objects produced by application + of the result of `(make-list-keyifier KEY-DIMENSION TYPES)'. This + procedure returns a KEY which is `equal?' to the COLUMN-NUMBERth + element of the list which was passed to create COMBINED-KEY. The + list TYPES must have at least KEY-DIMENSION elements. + + - Function: make-key->list KEY-DIMENSION TYPES + Returns a procedure which accepts objects produced by application + of the result of `(make-list-keyifier KEY-DIMENSION TYPES)'. This + procedure returns a list of KEYs which are elementwise `equal?' to + the list which was passed to create COMBINED-KEY. + +In the following functions, the KEY argument can always be assumed to +be the value returned by a call to a *keyify* routine. + + - Function: for-each-key HANDLE PROCEDURE + Calls PROCEDURE once with each KEY in the table opened in HANDLE + in an unspecified order. An unspecified value is returned. + + - Function: map-key HANDLE PROCEDURE + Returns a list of the values returned by calling PROCEDURE once + with each KEY in the table opened in HANDLE in an unspecified + order. + + - Function: ordered-for-each-key HANDLE PROCEDURE + Calls PROCEDURE once with each KEY in the table opened in HANDLE + in the natural order for the types of the primary key fields of + that table. An unspecified value is returned. + + - Function: present? HANDLE KEY + Returns a non-`#f' value if there is a row associated with KEY in + the table opened in HANDLE and `#f' otherwise. + + - Function: delete HANDLE KEY + Removes the row associated with KEY from the table opened in + HANDLE. An unspecified value is returned. + + - Function: make-getter KEY-DIMENSION TYPES + Returns a procedure which takes arguments HANDLE and KEY. This + procedure returns a list of the non-primary values of the relation + (in the base table opened in HANDLE) whose primary key is KEY if + it exists, and `#f' otherwise. + + - Function: make-putter KEY-DIMENSION TYPES + Returns a procedure which takes arguments HANDLE and KEY and + VALUE-LIST. This procedure associates the primary key KEY with + the values in VALUE-LIST (in the base table opened in HANDLE) and + returns an unspecified value. + + - Function: supported-type? SYMBOL + Returns `#t' if SYMBOL names a type allowed as a column value by + the implementation, and `#f' otherwise. At a minimum, an + implementation must support the types `integer', `symbol', + `string', `boolean', and `base-id'. + + - Function: supported-key-type? SYMBOL + Returns `#t' if SYMBOL names a type allowed as a key value by the + implementation, and `#f' otherwise. At a minimum, an + implementation must support the types `integer', and `symbol'. + +`integer' + Scheme exact integer. + +`symbol' + Scheme symbol. + +`boolean' + `#t' or `#f'. + +`base-id' + Objects suitable for passing as the BASE-ID parameter to + `open-table'. The value of CATALOG-ID must be an acceptable + `base-id'. + + +File: slib.info, Node: Relational Database, Next: Weight-Balanced Trees, Prev: Base Table, Up: Data Structures + +Relational Database +=================== + + `(require 'relational-database)' + + This package implements a database system inspired by the Relational +Model (`E. F. Codd, A Relational Model of Data for Large Shared Data +Banks'). An SLIB relational database implementation can be created +from any *Note Base Table:: implementation. + +* Menu: + +* Motivations:: Database Manifesto +* Creating and Opening Relational Databases:: +* Relational Database Operations:: +* Table Operations:: +* Catalog Representation:: +* Unresolved Issues:: +* Database Utilities:: 'database-utilities + + +File: slib.info, Node: Motivations, Next: Creating and Opening Relational Databases, Prev: Relational Database, Up: Relational Database + +Motivations +----------- + + Most nontrivial programs contain databases: Makefiles, configure +scripts, file backup, calendars, editors, source revision control, CAD +systems, display managers, menu GUIs, games, parsers, debuggers, +profilers, and even error reporting are all rife with databases. Coding +databases is such a common activity in programming that many may not be +aware of how often they do it. + + A database often starts as a dispatch in a program. The author, +perhaps because of the need to make the dispatch configurable, the need +for correlating dispatch in other routines, or because of changes or +growth, devises a data structure to contain the information, a routine +for interpreting that data structure, and perhaps routines for +augmenting and modifying the stored data. The dispatch must be +converted into this form and tested. + + The programmer may need to devise an interactive program for enabling +easy examination and modification of the information contained in this +database. Often, in an attempt to foster modularity and avoid delays in +release, intermediate file formats for the database information are +devised. It often turns out that users prefer modifying these +intermediate files with a text editor to using the interactive program +in order to do operations (such as global changes) not forseen by the +program's author. + + In order to address this need, the concientous software engineer may +even provide a scripting language to allow users to make repetitive +database changes. Users will grumble that they need to read a large +manual and learn yet another programming language (even if it *almost* +has language "xyz" syntax) in order to do simple configuration. + + All of these facilities need to be designed, coded, debugged, +documented, and supported; often causing what was very simple in concept +to become a major developement project. + + This view of databases just outlined is somewhat the reverse of the +view of the originators of the "Relational Model" of database +abstraction. The relational model was devised to unify and allow +interoperation of large multi-user databases running on diverse +platforms. A fairly general purpose "Comprehensive Language" for +database manipulations is mandated (but not specified) as part of the +relational model for databases. + + One aspect of the Relational Model of some importance is that the +"Comprehensive Language" must be expressible in some form which can be +stored in the database. This frees the programmer from having to make +programs data-driven in order to use a database. + + This package includes as one of its basic supported types Scheme +"expression"s. This type allows expressions as defined by the Scheme +standards to be stored in the database. Using `slib:eval' retrieved +expressions can be evaluated (in the top-level environment). Scheme's +`lambda' facilitates closure of environments, modularity, etc. so that +procedures (which could not be stored directly most databases) can +still be effectively retrieved. Since `slib:eval' evaluates +expressions in the top-level environment, built-in and user defined +procedures can be easily accessed by name. + + This package's purpose is to standardize (through a common interface) +database creation and usage in Scheme programs. The relational model's +provision for inclusion of language expressions as data as well as the +description (in tables, of course) of all of its tables assures that +relational databases are powerful enough to assume the roles currently +played by thousands of ad-hoc routines and data formats. + +Such standardization to a relational-like model brings many benefits: + + * Tables, fields, domains, and types can be dealt with by name in + programs. + + * The underlying database implementation can be changed (for + performance or other reasons) by changing a single line of code. + + * The formats of tables can be easily extended or changed without + altering code. + + * Consistency checks are specified as part of the table descriptions. + Changes in checks need only occur in one place. + + * All the configuration information which the developer wishes to + group together is easily grouped, without needing to change + programs aware of only some of these tables. + + * Generalized report generators, interactive entry programs, and + other database utilities can be part of a shared library. The + burden of adding configurability to a program is greatly reduced. + + * Scheme is the "comprehensive language" for these databases. + Scripting for configuration no longer needs to be in a separate + language with additional documentation. + + * Scheme's latent types mesh well with the strict typing and logical + requirements of the relational model. + + * Portable formats allow easy interchange of data. The included + table descriptions help prevent misinterpretation of format. + + +File: slib.info, Node: Creating and Opening Relational Databases, Next: Relational Database Operations, Prev: Motivations, Up: Relational Database + +Creating and Opening Relational Databases +----------------------------------------- + + - Function: make-relational-system BASE-TABLE-IMPLEMENTATION + Returns a procedure implementing a relational database using the + BASE-TABLE-IMPLEMENTATION. + + All of the operations of a base table implementation are accessed + through a procedure defined by `require'ing that implementation. + Similarly, all of the operations of the relational database + implementation are accessed through the procedure returned by + `make-relational-system'. For instance, a new relational database + could be created from the procedure returned by + `make-relational-system' by: + + (require 'alist-table) + (define relational-alist-system + (make-relational-system alist-table)) + (define create-alist-database + (relational-alist-system 'create-database)) + (define my-database + (create-alist-database "mydata.db")) + +What follows are the descriptions of the methods available from +relational system returned by a call to `make-relational-system'. + + - Function: create-database FILENAME + Returns an open, nearly empty relational database associated with + FILENAME. The only tables defined are the system catalog and + domain table. Calling the `close-database' method on this database + and possibly other operations will cause FILENAME to be written + to. If FILENAME is `#f' a temporary, non-disk based database will + be created if such can be supported by the underlying base table + implelentation. If the database cannot be created as specified + `#f' is returned. For the fields and layout of descriptor tables, + *Note Catalog Representation:: + + - Function: open-database FILENAME MUTABLE? + Returns an open relational database associated with FILENAME. If + MUTABLE? is `#t', this database will have methods capable of + effecting change to the database. If MUTABLE? is `#f', only + methods for inquiring the database will be available. Calling the + `close-database' (and possibly other) method on a MUTABLE? + database will cause FILENAME to be written to. If the database + cannot be opened as specified `#f' is returned. + + +File: slib.info, Node: Relational Database Operations, Next: Table Operations, Prev: Creating and Opening Relational Databases, Up: Relational Database + +Relational Database Operations +------------------------------ + +These are the descriptions of the methods available from an open +relational database. A method is retrieved from a database by calling +the database with the symbol name of the operation. For example: + + (define my-database + (create-alist-database "mydata.db")) + (define telephone-table-desc + ((my-database 'create-table) 'telephone-table-desc)) + + - Function: close-database + Causes the relational database to be written to its associated + file (if any). If the write is successful, subsequent operations + to this database will signal an error. If the operations completed + successfully, `#t' is returned. Otherwise, `#f' is returned. + + - Function: write-database FILENAME + Causes the relational database to be written to FILENAME. If the + write is successful, also causes the database to henceforth be + associated with FILENAME. Calling the `close-database' (and + possibly other) method on this database will cause FILENAME to be + written to. If FILENAME is `#f' this database will be changed to + a temporary, non-disk based database if such can be supported by + the underlying base table implelentation. If the operations + completed successfully, `#t' is returned. Otherwise, `#f' is + returned. + + - Function: table-exists? TABLE-NAME + Returns `#t' if TABLE-NAME exists in the system catalog, otherwise + returns `#f'. + + - Function: open-table TABLE-NAME MUTABLE? + Returns a "methods" procedure for an existing relational table in + this database if it exists and can be opened in the mode indicated + by MUTABLE?, otherwise returns `#f'. + +These methods will be present only in databases which are MUTABLE?. + + - Function: delete-table TABLE-NAME + Removes and returns the TABLE-NAME row from the system catalog if + the table or view associated with TABLE-NAME gets removed from the + database, and `#f' otherwise. + + - Function: create-table TABLE-DESC-NAME + Returns a methods procedure for a new (open) relational table for + describing the columns of a new base table in this database, + otherwise returns `#f'. For the fields and layout of descriptor + tables, *Note Catalog Representation::. + + - Function: create-table TABLE-NAME TABLE-DESC-NAME + Returns a methods procedure for a new (open) relational table with + columns as described by TABLE-DESC-NAME, otherwise returns `#f'. + + - Function: create-view ?? + - Function: project-table ?? + - Function: restrict-table ?? + - Function: cart-prod-tables ?? + Not yet implemented. + + +File: slib.info, Node: Table Operations, Next: Catalog Representation, Prev: Relational Database Operations, Up: Relational Database + +Table Operations +---------------- + +These are the descriptions of the methods available from an open +relational table. A method is retrieved from a table by calling the +table with the symbol name of the operation. For example: + + (define telephone-table-desc + ((my-database 'create-table) 'telephone-table-desc)) + (require 'common-list-functions) + (define ndrp (telephone-table-desc 'row:insert)) + (ndrp '(1 #t name #f string)) + (ndrp '(2 #f telephone + (lambda (d) + (and (string? d) (> (string-length d) 2) + (every + (lambda (c) + (memv c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + #\+ #\( #\ #\) #\-))) + (string->list d)))) + string)) + +Operations on a single column of a table are retrieved by giving the +column name as the second argument to the methods procedure. For +example: + + (define column-ids ((telephone-table-desc 'get* 'column-number))) + +Some operations described below require primary key arguments. Primary +keys arguments are denoted KEY1 KEY2 .... It is an error to call an +operation for a table which takes primary key arguments with the wrong +number of primary keys for that table. + +The term "row" used below refers to a Scheme list of values (one for +each column) in the order specified in the descriptor (table) for this +table. Missing values appear as `#f'. Primary keys may not be missing. + + - Function: get KEY1 KEY2 ... + Returns the value for the specified column of the row associated + with primary keys KEY1, KEY2 ... if it exists, or `#f' otherwise. + + - Function: get* + Returns a list of the values for the specified column for all rows + in this table. + + - Function: row:retrieve KEY1 KEY2 ... + Returns the row associated with primary keys KEY1, KEY2 ... if it + exists, or `#f' otherwise. + + - Function: row:retrieve* + Returns a list of all rows in this table. + + - Function: row:remove KEY1 KEY2 ... + Removes and returns the row associated with primary keys KEY1, + KEY2 ... if it exists, or `#f' otherwise. + + - Function: row:remove* + Removes and returns a list of all rows in this table. + + - Function: row:delete KEY1 KEY2 ... + Deletes the row associated with primary keys KEY1, KEY2 ... if it + exists. The value returned is unspecified. + + - Function: row:delete* + Deletes all rows in this table. The value returned is + unspecified. The descriptor table and catalog entry for this + table are not affected. + + - Function: row:update ROW + Adds the row, ROW, to this table. If a row for the primary key(s) + specified by ROW already exists in this table, it will be + overwritten. The value returned is unspecified. + + - Function: row:update* ROWS + Adds each row in the list ROWS, to this table. If a row for the + primary key specified by an element of ROWS already exists in this + table, it will be overwritten. The value returned is unspecified. + + - Function: row:insert ROW + Adds the row ROW to this table. If a row for the primary key(s) + specified by ROW already exists in this table an error is + signaled. The value returned is unspecified. + + - Function: row:insert* ROWS + Adds each row in the list ROWS, to this table. If a row for the + primary key specified by an element of ROWS already exists in this + table, an error is signaled. The value returned is unspecified. + + - Function: for-each-row PROC + Calls PROC with each ROW in this table in the natural ordering for + the primary key types. *Real* relational programmers would use + some least-upper-bound join for every row to get them in order; + But we don't have joins yet. + + - Function: close-table + Subsequent operations to this table will signal an error. + + - Constant: column-names + - Constant: column-foreigns + - Constant: column-domains + - Constant: column-types + Return a list of the column names, foreign-key table names, domain + names, or type names respectively for this table. These 4 methods + are different from the others in that the list is returned, rather + than a procedure to obtain the list. + + - Constant: primary-limit + Returns the number of primary keys fields in the relations in this + table. + + +File: slib.info, Node: Catalog Representation, Next: Unresolved Issues, Prev: Table Operations, Up: Relational Database + +Catalog Representation +---------------------- + +Each database (in an implementation) has a "system catalog" which +describes all the user accessible tables in that database (including +itself). + +The system catalog base table has the following fields. `PRI' +indicates a primary key for that table. + + PRI table-name + column-limit the highest column number + coltab-name descriptor table name + bastab-id data base table identifier + user-integrity-rule + view-procedure A scheme thunk which, when called, + produces a handle for the view. coltab + and bastab are specified if and only if + view-procedure is not. + +Descriptors for base tables (not views) are tables (pointed to by +system catalog). Descriptor (base) tables have the fields: + + PRI column-number sequential integers from 1 + primary-key? boolean TRUE for primary key components + column-name + column-integrity-rule + domain-name + +A "primary key" is any column marked as `primary-key?' in the +corresponding descriptor table. All the `primary-key?' columns must +have lower column numbers than any non-`primary-key?' columns. Every +table must have at least one primary key. Primary keys must be +sufficient to distinguish all rows from each other in the table. All of +the system defined tables have a single primary key. + +This package currently supports tables having from 1 to 4 primary keys +if there are non-primary columns, and any (natural) number if *all* +columns are primary keys. If you need more than 4 primary keys, I would +like to hear what you are doing! + +A "domain" is a category describing the allowable values to occur in a +column. It is described by a (base) table with the fields: + + PRI domain-name + foreign-table + domain-integrity-rule + type-id + type-param + +The "type-id" field value is a symbol. This symbol may be used by the +underlying base table implementation in storing that field. + +If the `foreign-table' field is non-`#f' then that field names a table +from the catalog. The values for that domain must match a primary key +of the table referenced by the TYPE-PARAM (or `#f', if allowed). This +package currently does not support composite foreign-keys. + +The types for which support is planned are: + atom + symbol + string [] + number [] + money + date-time + boolean + + foreign-key + expression + virtual + + +File: slib.info, Node: Unresolved Issues, Next: Database Utilities, Prev: Catalog Representation, Up: Relational Database + +Unresolved Issues +----------------- + + Although `rdms.scm' is not large I found it very difficult to write +(six rewrites). I am not aware of any other examples of a generalized +relational system (although there is little new in CS). I left out +several aspects of the Relational model in order to simplify the job. +The major features lacking (which might be addressed portably) are +views, transaction boundaries, and protection. + + Protection needs a model for specifying priveledges. Given how +operations are accessed from handles it should not be difficult to +restrict table accesses to those allowed for that user. + + The system catalog has a field called `view-procedure'. This should +allow a purely functional implementation of views. This will work but +is unsatisfying for views resulting from a "select"ion (subset of +rows); for whole table operations it will not be possible to reduce the +number of keys scanned over when the selection is specified only by an +opaque procedure. + + Transaction boundaries present the most intriguing area. Transaction +boundaries are actually a feature of the "Comprehensive Language" of the +Relational database and not of the database. Scheme would seem to +provide the opportunity for an extremely clean semantics for transaction +boundaries since the builtin procedures with side effects are small in +number and easily identified. + + These side-effect builtin procedures might all be portably redefined +to versions which properly handled transactions. Compiled library +routines would need to be recompiled as well. Many system extensions +(delete-file, system, etc.) would also need to be redefined. + +There are 2 scope issues that must be resolved for multiprocess +transaction boundaries: + +Process scope + The actions captured by a transaction should be only for the + process which invoked the start of transaction. Although standard + Scheme does not provide process primitives as such, `dynamic-wind' + would provide a workable hook into process switching for many + implementations. + +Shared utilities with state + Some shared utilities have state which should *not* be part of a + transaction. An example would be calling a pseudo-random number + generator. If the success of a transaction depended on the + pseudo-random number and failed, the state of the generator would + be set back. Subsequent calls would keep returning the same + number and keep failing. + + Pseudo-random number generators are not reentrant and so would + require locks in order to operate properly in a multiprocess + environment. Are all examples of utilities whose state should not + part of transactions also non-reentrant? If so, perhaps + suspending transaction capture for the duration of locks would fix + it. + + +File: slib.info, Node: Database Utilities, Prev: Unresolved Issues, Up: Relational Database + +Database Utilities +------------------ + + `(require 'database-utilities)' + +This enhancement wraps a utility layer on `relational-database' which +provides: + * Automatic loading of the appropriate base-table package when + opening a database. + + * Automatic execution of initialization commands stored in database. + + * Transparent execution of database commands stored in `*commands*' + table in database. + +Also included are utilities which provide: + * Data definition from Scheme lists and + + * Report generation + +for any SLIB relational database. + + - Function: create-database FILENAME BASE-TABLE-TYPE + Returns an open, nearly empty enhanced (with `*commands*' table) + relational database (with base-table type BASE-TABLE-TYPE) + associated with FILENAME. + + - Function: open-database FILENAME + - Function: open-database FILENAME BASE-TABLE-TYPE + Returns an open enchanced relational database associated with + FILENAME. The database will be opened with base-table type + BASE-TABLE-TYPE) if supplied. If BASE-TABLE-TYPE is not supplied, + `open-database' will attempt to deduce the correct + base-table-type. If the database can not be opened or if it lacks + the `*commands*' table, `#f' is returned. + + - Function: open-database! FILENAME + - Function: open-database! FILENAME BASE-TABLE-TYPE + Returns *mutable* open enchanced relational database ... + +The table `*commands*' in an "enhanced" relational-database has the +fields (with domains): + PRI name symbol + parameters parameter-list + procedure expression + documentation string + + The `parameters' field is a foreign key (domain `parameter-list') of +the `*catalog-data*' table and should have the value of a table +described by `*parameter-columns*'. This `parameter-list' table +describes the arguments suitable for passing to the associated command. +The intent of this table is to be of a form such that different +user-interfaces (for instance, pull-down menus or plain-text queries) +can operate from the same table. A `parameter-list' table has the +following fields: + PRI index uint + name symbol + arity parameter-arity + domain domain + default expression + documentation string + + The `arity' field can take the values: + +`single' + Requires a single parameter of the specified domain. + +`optional' + A single parameter of the specified domain or zero parameters is + acceptable. + +`boolean' + A single boolean parameter or zero parameters (in which case `#f' + is substituted) is acceptable. + +`nary' + Any number of parameters of the specified domain are acceptable. + The argument passed to the command function is always a list of the + parameters. + +`nary1' + One or more of parameters of the specified domain are acceptable. + The argument passed to the command function is always a list of the + parameters. + + The `domain' field specifies the domain which a parameter or +parameters in the `index'th field must satisfy. + + The `default' field is an expression whose value is either `#f' or a +procedure of no arguments which returns a parameter or parameter list +as appropriate. If the expression's value is `#f' then no default is +appropriate for this parameter. Note that since the `default' +procedure is called every time a default parameter is needed for this +column, "sticky" defaults can be implemented using shared state with +the domain-integrity-rule. + +Invoking Commands +................. + + When an enhanced relational-database is called with a symbol which +matches a NAME in the `*commands*' table, the associated procedure +expression is evaluated and applied to the enhanced +relational-database. A procedure should then be returned which the user +can invoke on (optional) arguments. + + The command `*initialize*' is special. If present in the +`*commands*' table, `open-database' or `open-database!' will return the +value of the `*initialize*' command. Notice that arbitrary code can be +run when the `*initialize*' procedure is automatically applied to the +enhanced relational-database. + + Note also that if you wish to shadow or hide from the user +relational-database methods described in *Note Relational Database +Operations::, this can be done by a dispatch in the closure returned by +the `*initialize*' expression rather than by entries in the +`*commands*' table if it is desired that the underlying methods remain +accessible to code in the `*commands*' table. + + - Function: make-command-server RDB TABLE-NAME + Returns a procedure of 2 arguments, a (symbol) command and a + call-back procedure. When this returned procedure is called, it + looks up COMMAND in table TABLE-NAME and calls the call-back + procedure with arguments: + COMMAND + The COMMAND + + COMMAND-VALUE + The result of evaluating the expression in the PROCEDURE + field of TABLE-NAME and calling it with RDB. + + PARAMETER-NAME + A list of the "official" name of each parameter. Corresponds + to the `name' field of the COMMAND's parameter-table. + + POSITIONS + A list of the positive integer index of each parameter. + Corresponds to the `index' field of the COMMAND's + parameter-table. + + ARITIES + A list of the arities of each parameter. Corresponds to the + `arity' field of the COMMAND's parameter-table. For a + description of `arity' see table above. + + DEFAULTS + A list of the defaults for each parameter. Corresponds to + the `defaults' field of the COMMAND's parameter-table. + + DOMAIN-INTEGRITY-RULES + A list of procedures (one for each parameter) which tests + whether a value for a parameter is acceptable for that + parameter. The procedure should be called with each datum in + the list for `nary' arity parameters. + + ALIASES + A list of lists of `(alias parameter-name)'. There can be + more than one alias per PARAMETER-NAME. + + For information about parameters, *Note Parameter lists::. Here is an +example of setting up a command with arguments and parsing those +arguments from a `getopt' style argument list (*note Getopt::.). + + (require 'database-utilities) + (require 'parameters) + (require 'getopt) + + (define my-rdb (create-database #f 'alist-table)) + + (define-tables my-rdb + '(foo-params + *parameter-columns* + *parameter-columns* + ((1 first-argument single string "hithere" "first argument") + (2 flag boolean boolean #f "a flag"))) + '(foo-pnames + ((name string)) + ((parameter-index uint)) + (("l" 1) + ("a" 2))) + '(my-commands + ((name symbol)) + ((parameters parameter-list) + (parameter-names parameter-name-translation) + (procedure expression) + (documentation string)) + ((foo + foo-params + foo-pnames + (lambda (rdb) (lambda (foo aflag) (print foo aflag))) + "test command arguments")))) + + (define (dbutil:serve-command-line rdb command-table + command argc argv) + (set! argv (if (vector? argv) (vector->list argv) argv)) + ((make-command-server rdb command-table) + command + (lambda (comname comval options positions + arities types defaults dirs aliases) + (apply comval (getopt->arglist argc argv options positions + arities types defaults dirs aliases))))) + + (define (test) + (set! *optind* 1) + (dbutil:serve-command-line + my-rdb 'my-commands 'foo 4 '("dummy" "-l" "foo" "-a"))) + (test) + -| + "foo" #t + + Some commands are defined in all extended relational-databases. The +are called just like *Note Relational Database Operations::. + + - Function: add-domain DOMAIN-ROW + Adds DOMAIN-ROW to the "domains" table if there is no row in the + domains table associated with key `(car DOMAIN-ROW)' and returns + `#t'. Otherwise returns `#f'. + + For the fields and layout of the domain table, *Note Catalog + Representation:: + + - Function: delete-domain DOMAIN-NAME + Removes and returns the DOMAIN-NAME row from the "domains" table. + + - Function: domain-checker DOMAIN + Returns a procedure to check an argument for conformance to domain + DOMAIN. + +Defining Tables +--------------- + + - Procedure: define-tables RDB SPEC-0 ... + Adds tables as specified in SPEC-0 ... to the open + relational-database RDB. Each SPEC has the form: + + ( ) + or + ( ) + + where is the table name, is the symbol + name of a descriptor table, and + describe the primary keys and other fields + respectively, and is a list of data rows to be added to the + table. + + and are lists of field + descriptors of the form: + + ( ) + or + ( ) + + where is the column name, is the domain of + the column, and is an expression whose + value is a procedure of one argument (and returns non-`#f' to + signal an error). + + If is not a defined domain name and it matches the name of + this table or an already defined (in one of SPEC-0 ...) single key + field table, a foriegn-key domain will be created for it. + + - Procedure: create-report RDB DESTINATION REPORT-NAME TABLE + - Procedure: create-report RDB DESTINATION REPORT-NAME + The symbol REPORT-NAME must be primary key in the table named + `*reports*' in the relational database RDB. DESTINATION is a + port, string, or symbol. If DESTINATION is a: + + port + The table is created as ascii text and written to that port. + + string + The table is created as ascii text and written to the file + named by DESTINATION. + + symbol + DESTINATION is the primary key for a row in the table named + *printers*. + + Each row in the table *reports* has the fields: + + name + The report name. + + default-table + The table to report on if none is specified. + + header, footer + A `format' string. At the beginning and end of each page + respectively, `format' is called with this string and the + (list of) column-names of this table. + + reporter + A `format' string. For each row in the table, `format' is + called with this string and the row. + + minimum-break + The minimum number of lines into which the report lines for a + row can be broken. Use `0' if a row's lines should not be + broken over page boundaries. + + Each row in the table *printers* has the fields: + + name + The printer name. + + print-procedure + The procedure to call to actually print. + + The report is prepared as follows: + + `Format' (*note Format::.) is called with the `header' field + and the (list of) `column-names' of the table. + + `Format' is called with the `reporter' field and (on + successive calls) each record in the natural order for the + table. A count is kept of the number of newlines output by + format. When the number of newlines to be output exceeds the + number of lines per page, the set of lines will be broken if + there are more than `minimum-break' left on this page and the + number of lines for this row is larger or equal to twice + `minimum-break'. + + `Format' is called with the `footer' field and the (list of) + `column-names' of the table. The footer field should not + output a newline. + + A new page is output. + + This entire process repeats until all the rows are output. + +The following example shows a new database with the name of `foo.db' +being created with tables describing processor families and +processor/os/compiler combinations. + +The database command `define-tables' is defined to call `define-tables' +with its arguments. The database is also configured to print `Welcome' +when the database is opened. The database is then closed and reopened. + + (require 'database-utilities) + (define my-rdb (create-database "foo.db" 'alist-table)) + + (define-tables my-rdb + '(*commands* + ((name symbol)) + ((parameters parameter-list) + (procedure expression) + (documentation string)) + ((define-tables + no-parameters + no-parameter-names + (lambda (rdb) (lambda specs (apply define-tables rdb specs))) + "Create or Augment tables from list of specs") + (*initialize* + no-parameters + no-parameter-names + (lambda (rdb) (display "Welcome") (newline) rdb) + "Print Welcome")))) + + ((my-rdb 'define-tables) + '(processor-family + ((family atom)) + ((also-ran processor-family)) + ((m68000 #f) + (m68030 m68000) + (i386 8086) + (8086 #f) + (powerpc #f))) + + '(platform + ((name symbol)) + ((processor processor-family) + (os symbol) + (compiler symbol)) + ((aix powerpc aix -) + (amiga-dice-c m68000 amiga dice-c) + (amiga-aztec m68000 amiga aztec) + (amiga-sas/c-5.10 m68000 amiga sas/c) + (atari-st-gcc m68000 atari gcc) + (atari-st-turbo-c m68000 atari turbo-c) + (borland-c-3.1 8086 ms-dos borland-c) + (djgpp i386 ms-dos gcc) + (linux i386 linux gcc) + (microsoft-c 8086 ms-dos microsoft-c) + (os/2-emx i386 os/2 gcc) + (turbo-c-2 8086 ms-dos turbo-c) + (watcom-9.0 i386 ms-dos watcom)))) + + ((my-rdb 'close-database)) + + (set! my-rdb (open-database "foo.db" 'alist-table)) + -| + Welcome + diff --git a/slib.info-3 b/slib.info-3 new file mode 100644 index 0000000..7109890 --- /dev/null +++ b/slib.info-3 @@ -0,0 +1,859 @@ +This is Info file slib.info, produced by Makeinfo-1.64 from the input +file slib.texi. + + This file documents SLIB, the portable Scheme library. + + Copyright (C) 1993 Todd R. Eigenschink Copyright (C) 1993, 1994, 1995 +Aubrey Jaffer + + Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + + Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + + Permission is granted to copy and distribute translations of this +manual into another language, under the above conditions for modified +versions, except that this permission notice may be stated in a +translation approved by the author. + + +File: slib.info, Node: Weight-Balanced Trees, Next: Structures, Prev: Relational Database, Up: Data Structures + +Weight-Balanced Trees +===================== + + `(require 'wt-tree)' + + Balanced binary trees are a useful data structure for maintaining +large sets of ordered objects or sets of associations whose keys are +ordered. MIT Scheme has an comprehensive implementation of +weight-balanced binary trees which has several advantages over the +other data structures for large aggregates: + + * In addition to the usual element-level operations like insertion, + deletion and lookup, there is a full complement of collection-level + operations, like set intersection, set union and subset test, all + of which are implemented with good orders of growth in time and + space. This makes weight balanced trees ideal for rapid + prototyping of functionally derived specifications. + + * An element in a tree may be indexed by its position under the + ordering of the keys, and the ordinal position of an element may + be determined, both with reasonable efficiency. + + * Operations to find and remove minimum element make weight balanced + trees simple to use for priority queues. + + * The implementation is *functional* rather than *imperative*. This + means that operations like `inserting' an association in a tree do + not destroy the old tree, in much the same way that `(+ 1 x)' + modifies neither the constant 1 nor the value bound to `x'. The + trees are referentially transparent thus the programmer need not + worry about copying the trees. Referential transparency allows + space efficiency to be achieved by sharing subtrees. + + These features make weight-balanced trees suitable for a wide range of +applications, especially those that require large numbers of sets or +discrete maps. Applications that have a few global databases and/or +concentrate on element-level operations like insertion and lookup are +probably better off using hash-tables or red-black trees. + + The *size* of a tree is the number of associations that it contains. +Weight balanced binary trees are balanced to keep the sizes of the +subtrees of each node within a constant factor of each other. This +ensures logarithmic times for single-path operations (like lookup and +insertion). A weight balanced tree takes space that is proportional to +the number of associations in the tree. For the current +implementation, the constant of proportionality is six words per +association. + + Weight balanced trees can be used as an implementation for either +discrete sets or discrete maps (associations). Sets are implemented by +ignoring the datum that is associated with the key. Under this scheme +if an associations exists in the tree this indicates that the key of the +association is a member of the set. Typically a value such as `()', +`#t' or `#f' is associated with the key. + + Many operations can be viewed as computing a result that, depending on +whether the tree arguments are thought of as sets or maps, is known by +two different names. An example is `wt-tree/member?', which, when +regarding the tree argument as a set, computes the set membership +operation, but, when regarding the tree as a discrete map, +`wt-tree/member?' is the predicate testing if the map is defined at an +element in its domain. Most names in this package have been chosen +based on interpreting the trees as sets, hence the name +`wt-tree/member?' rather than `wt-tree/defined-at?'. + + The weight balanced tree implementation is a run-time-loadable option. +To use weight balanced trees, execute + + (load-option 'wt-tree) + +once before calling any of the procedures defined here. + +* Menu: + +* Construction of Weight-Balanced Trees:: +* Basic Operations on Weight-Balanced Trees:: +* Advanced Operations on Weight-Balanced Trees:: +* Indexing Operations on Weight-Balanced Trees:: + + +File: slib.info, Node: Construction of Weight-Balanced Trees, Next: Basic Operations on Weight-Balanced Trees, Prev: Weight-Balanced Trees, Up: Weight-Balanced Trees + +Construction of Weight-Balanced Trees +------------------------------------- + + Binary trees require there to be a total order on the keys used to +arrange the elements in the tree. Weight balanced trees are organized +by *types*, where the type is an object encapsulating the ordering +relation. Creating a tree is a two-stage process. First a tree type +must be created from the predicate which gives the ordering. The tree +type is then used for making trees, either empty or singleton trees or +trees from other aggregate structures like association lists. Once +created, a tree `knows' its type and the type is used to test +compatibility between trees in operations taking two trees. Usually a +small number of tree types are created at the beginning of a program +and used many times throughout the program's execution. + + - procedure+: make-wt-tree-type KEY #f + (and (key #f + (if (and (key #t + + Two key values are assumed to be equal if neither is less than the + other by KEYwt-tree TREE-TYPE ALIST + Returns a newly allocated weight-balanced tree that contains the + same associations as ALIST. This procedure is equivalent to: + + (lambda (type alist) + (let ((tree (make-wt-tree type))) + (for-each (lambda (association) + (wt-tree/add! tree + (car association) + (cdr association))) + alist) + tree)) + + +File: slib.info, Node: Basic Operations on Weight-Balanced Trees, Next: Advanced Operations on Weight-Balanced Trees, Prev: Construction of Weight-Balanced Trees, Up: Weight-Balanced Trees + +Basic Operations on Weight-Balanced Trees +----------------------------------------- + + This section describes the basic tree operations on weight balanced +trees. These operations are the usual tree operations for insertion, +deletion and lookup, some predicates and a procedure for determining the +number of associations in a tree. + + - procedure+: wt-tree? OBJECT + Returns `#t' if OBJECT is a weight-balanced tree, otherwise + returns `#f'. + + - procedure+: wt-tree/empty? WT-TREE + Returns `#t' if WT-TREE contains no associations, otherwise + returns `#f'. + + - procedure+: wt-tree/size WT-TREE + Returns the number of associations in WT-TREE, an exact + non-negative integer. This operation takes constant time. + + - procedure+: wt-tree/add WT-TREE KEY DATUM + Returns a new tree containing all the associations in WT-TREE and + the association of DATUM with KEY. If WT-TREE already had an + association for KEY, the new association overrides the old. The + average and worst-case times required by this operation are + proportional to the logarithm of the number of associations in + WT-TREE. + + - procedure+: wt-tree/add! WT-TREE KEY DATUM + Associates DATUM with KEY in WT-TREE and returns an unspecified + value. If WT-TREE already has an association for KEY, that + association is replaced. The average and worst-case times + required by this operation are proportional to the logarithm of + the number of associations in WT-TREE. + + - procedure+: wt-tree/member? KEY WT-TREE + Returns `#t' if WT-TREE contains an association for KEY, otherwise + returns `#f'. The average and worst-case times required by this + operation are proportional to the logarithm of the number of + associations in WT-TREE. + + - procedure+: wt-tree/lookup WT-TREE KEY DEFAULT + Returns the datum associated with KEY in WT-TREE. If WT-TREE + doesn't contain an association for KEY, DEFAULT is returned. The + average and worst-case times required by this operation are + proportional to the logarithm of the number of associations in + WT-TREE. + + - procedure+: wt-tree/delete WT-TREE KEY + Returns a new tree containing all the associations in WT-TREE, + except that if WT-TREE contains an association for KEY, it is + removed from the result. The average and worst-case times required + by this operation are proportional to the logarithm of the number + of associations in WT-TREE. + + - procedure+: wt-tree/delete! WT-TREE KEY + If WT-TREE contains an association for KEY the association is + removed. Returns an unspecified value. The average and worst-case + times required by this operation are proportional to the logarithm + of the number of associations in WT-TREE. + + +File: slib.info, Node: Advanced Operations on Weight-Balanced Trees, Next: Indexing Operations on Weight-Balanced Trees, Prev: Basic Operations on Weight-Balanced Trees, Up: Weight-Balanced Trees + +Advanced Operations on Weight-Balanced Trees +-------------------------------------------- + + In the following the *size* of a tree is the number of associations +that the tree contains, and a *smaller* tree contains fewer +associations. + + - procedure+: wt-tree/split< WT-TREE BOUND + Returns a new tree containing all and only the associations in + WT-TREE which have a key that is less than BOUND in the ordering + relation of the tree type of WT-TREE. The average and worst-case + times required by this operation are proportional to the logarithm + of the size of WT-TREE. + + - procedure+: wt-tree/split> WT-TREE BOUND + Returns a new tree containing all and only the associations in + WT-TREE which have a key that is greater than BOUND in the + ordering relation of the tree type of WT-TREE. The average and + worst-case times required by this operation are proportional to the + logarithm of size of WT-TREE. + + - procedure+: wt-tree/union WT-TREE-1 WT-TREE-2 + Returns a new tree containing all the associations from both trees. + This operation is asymmetric: when both trees have an association + for the same key, the returned tree associates the datum from + WT-TREE-2 with the key. Thus if the trees are viewed as discrete + maps then `wt-tree/union' computes the map override of WT-TREE-1 by + WT-TREE-2. If the trees are viewed as sets the result is the set + union of the arguments. The worst-case time required by this + operation is proportional to the sum of the sizes of both trees. + If the minimum key of one tree is greater than the maximum key of + the other tree then the time required is at worst proportional to + the logarithm of the size of the larger tree. + + - procedure+: wt-tree/intersection WT-TREE-1 WT-TREE-2 + Returns a new tree containing all and only those associations from + WT-TREE-1 which have keys appearing as the key of an association + in WT-TREE-2. Thus the associated data in the result are those + from WT-TREE-1. If the trees are being used as sets the result is + the set intersection of the arguments. As a discrete map + operation, `wt-tree/intersection' computes the domain restriction + of WT-TREE-1 to (the domain of) WT-TREE-2. The time required by + this operation is never worse that proportional to the sum of the + sizes of the trees. + + - procedure+: wt-tree/difference WT-TREE-1 WT-TREE-2 + Returns a new tree containing all and only those associations from + WT-TREE-1 which have keys that *do not* appear as the key of an + association in WT-TREE-2. If the trees are viewed as sets the + result is the asymmetric set difference of the arguments. As a + discrete map operation, it computes the domain restriction of + WT-TREE-1 to the complement of (the domain of) WT-TREE-2. The + time required by this operation is never worse that proportional to + the sum of the sizes of the trees. + + - procedure+: wt-tree/subset? WT-TREE-1 WT-TREE-2 + Returns `#t' iff the key of each association in WT-TREE-1 is the + key of some association in WT-TREE-2, otherwise returns `#f'. + Viewed as a set operation, `wt-tree/subset?' is the improper subset + predicate. A proper subset predicate can be constructed: + + (define (proper-subset? s1 s2) + (and (wt-tree/subset? s1 s2) + (< (wt-tree/size s1) (wt-tree/size s2)))) + + As a discrete map operation, `wt-tree/subset?' is the subset test + on the domain(s) of the map(s). In the worst-case the time + required by this operation is proportional to the size of + WT-TREE-1. + + - procedure+: wt-tree/set-equal? WT-TREE-1 WT-TREE-2 + Returns `#t' iff for every association in WT-TREE-1 there is an + association in WT-TREE-2 that has the same key, and *vice versa*. + + Viewing the arguments as sets `wt-tree/set-equal?' is the set + equality predicate. As a map operation it determines if two maps + are defined on the same domain. + + This procedure is equivalent to + + (lambda (wt-tree-1 wt-tree-2) + (and (wt-tree/subset? wt-tree-1 wt-tree-2 + (wt-tree/subset? wt-tree-2 wt-tree-1))) + + In the worst-case the time required by this operation is + proportional to the size of the smaller tree. + + - procedure+: wt-tree/fold COMBINER INITIAL WT-TREE + This procedure reduces WT-TREE by combining all the associations, + using an reverse in-order traversal, so the associations are + visited in reverse order. COMBINER is a procedure of three + arguments: a key, a datum and the accumulated result so far. + Provided COMBINER takes time bounded by a constant, `wt-tree/fold' + takes time proportional to the size of WT-TREE. + + A sorted association list can be derived simply: + + (wt-tree/fold (lambda (key datum list) + (cons (cons key datum) list)) + '() + WT-TREE)) + + The data in the associations can be summed like this: + + (wt-tree/fold (lambda (key datum sum) (+ sum datum)) + 0 + WT-TREE) + + - procedure+: wt-tree/for-each ACTION WT-TREE + This procedure traverses the tree in-order, applying ACTION to + each association. The associations are processed in increasing + order of their keys. ACTION is a procedure of two arguments which + take the key and datum respectively of the association. Provided + ACTION takes time bounded by a constant, `wt-tree/for-each' takes + time proportional to in the size of WT-TREE. The example prints + the tree: + + (wt-tree/for-each (lambda (key value) + (display (list key value))) + WT-TREE)) + + +File: slib.info, Node: Indexing Operations on Weight-Balanced Trees, Prev: Advanced Operations on Weight-Balanced Trees, Up: Weight-Balanced Trees + +Indexing Operations on Weight-Balanced Trees +-------------------------------------------- + + Weight balanced trees support operations that view the tree as sorted +sequence of associations. Elements of the sequence can be accessed by +position, and the position of an element in the sequence can be +determined, both in logarthmic time. + + - procedure+: wt-tree/index WT-TREE INDEX + - procedure+: wt-tree/index-datum WT-TREE INDEX + - procedure+: wt-tree/index-pair WT-TREE INDEX + Returns the 0-based INDEXth association of WT-TREE in the sorted + sequence under the tree's ordering relation on the keys. + `wt-tree/index' returns the INDEXth key, `wt-tree/index-datum' + returns the datum associated with the INDEXth key and + `wt-tree/index-pair' returns a new pair `(KEY . DATUM)' which is + the `cons' of the INDEXth key and its datum. The average and + worst-case times required by this operation are proportional to + the logarithm of the number of associations in the tree. + + These operations signal an error if the tree is empty, if + INDEX`<0', or if INDEX is greater than or equal to the number of + associations in the tree. + + Indexing can be used to find the median and maximum keys in the + tree as follows: + + median: (wt-tree/index WT-TREE (quotient (wt-tree/size WT-TREE) 2)) + + maximum: (wt-tree/index WT-TREE (-1+ (wt-tree/size WT-TREE))) + + - procedure+: wt-tree/rank WT-TREE KEY + Determines the 0-based position of KEY in the sorted sequence of + the keys under the tree's ordering relation, or `#f' if the tree + has no association with for KEY. This procedure returns either an + exact non-negative integer or `#f'. The average and worst-case + times required by this operation are proportional to the logarithm + of the number of associations in the tree. + + - procedure+: wt-tree/min WT-TREE + - procedure+: wt-tree/min-datum WT-TREE + - procedure+: wt-tree/min-pair WT-TREE + Returns the association of WT-TREE that has the least key under + the tree's ordering relation. `wt-tree/min' returns the least key, + `wt-tree/min-datum' returns the datum associated with the least + key and `wt-tree/min-pair' returns a new pair `(key . datum)' + which is the `cons' of the minimum key and its datum. The average + and worst-case times required by this operation are proportional + to the logarithm of the number of associations in the tree. + + These operations signal an error if the tree is empty. They could + be written + (define (wt-tree/min tree) (wt-tree/index tree 0)) + (define (wt-tree/min-datum tree) (wt-tree/index-datum tree 0)) + (define (wt-tree/min-pair tree) (wt-tree/index-pair tree 0)) + + - procedure+: wt-tree/delete-min WT-TREE + Returns a new tree containing all of the associations in WT-TREE + except the association with the least key under the WT-TREE's + ordering relation. An error is signalled if the tree is empty. + The average and worst-case times required by this operation are + proportional to the logarithm of the number of associations in the + tree. This operation is equivalent to + + (wt-tree/delete WT-TREE (wt-tree/min WT-TREE)) + + - procedure+: wt-tree/delete-min! WT-TREE + Removes the association with the least key under the WT-TREE's + ordering relation. An error is signalled if the tree is empty. + The average and worst-case times required by this operation are + proportional to the logarithm of the number of associations in the + tree. This operation is equivalent to + + (wt-tree/delete! WT-TREE (wt-tree/min WT-TREE)) + + +File: slib.info, Node: Structures, Prev: Weight-Balanced Trees, Up: Data Structures + +Structures +========== + + `(require 'struct)' (uses defmacros) + + `defmacro's which implement "records" from the book `Essentials of +Programming Languages' by Daniel P. Friedman, M. Wand and C.T. Haynes. +Copyright 1992 Jeff Alexander, Shinnder Lee, and Lewis Patterson + + Matthew McDonald added field setters. + + - Macro: define-record TAG (VAR1 VAR2 ...) + Defines several functions pertaining to record-name TAG: + + - Function: make-TAG VAR1 VAR2 ... + + - Function: TAG? OBJ + + - Function: TAG->VAR1 OBJ + + - Function: TAG->VAR2 OBJ + ... + + - Function: set-TAG-VAR1! OBJ VAL + + - Function: set-TAG-VAR2! OBJ VAL + ... + + Here is an example of its use. + + (define-record term (operator left right)) + => # + (define foo (make-term 'plus 1 2)) + => foo + (term-left foo) + => 1 + (set-term-left! foo 2345) + => # + (term-left foo) + => 2345 + + - Macro: variant-case EXP (TAG (VAR1 VAR2 ...) BODY) ... + executes the following for the matching clause: + + ((lambda (VAR1 VAR ...) BODY) + (TAG->VAR1 EXP) + (TAG->VAR2 EXP) ...) + + +File: slib.info, Node: Macros, Next: Numerics, Prev: Data Structures, Up: Top + +Macros +****** + +* Menu: + +* Defmacro:: Supported by all implementations + +* R4RS Macros:: 'macro +* Macro by Example:: 'macro-by-example +* Macros That Work:: 'macros-that-work +* Syntactic Closures:: 'syntactic-closures +* Syntax-Case Macros:: 'syntax-case + +Syntax extensions (macros) included with SLIB. Also *Note Structures::. + +* Fluid-Let:: 'fluid-let +* Yasos:: 'yasos, 'oop, 'collect + + +File: slib.info, Node: Defmacro, Next: R4RS Macros, Prev: Macros, Up: Macros + +Defmacro +======== + + Defmacros are supported by all implementations. + + - Function: gentemp + Returns a new (interned) symbol each time it is called. The symbol + names are implementation-dependent + (gentemp) => scm:G0 + (gentemp) => scm:G1 + + - Function: defmacro:eval E + Returns the `slib:eval' of expanding all defmacros in scheme + expression E. + + - Function: defmacro:load FILENAME + FILENAME should be a string. If filename names an existing file, + the `defmacro:load' procedure reads Scheme source code expressions + and definitions from the file and evaluates them sequentially. + These source code expressions and definitions may contain defmacro + definitions. The `macro:load' procedure does not affect the values + returned by `current-input-port' and `current-output-port'. + + - Function: defmacro? SYM + Returns `#t' if SYM has been defined by `defmacro', `#f' otherwise. + + - Function: macroexpand-1 FORM + - Function: macroexpand FORM + If FORM is a macro call, `macroexpand-1' will expand the macro + call once and return it. A FORM is considered to be a macro call + only if it is a cons whose `car' is a symbol for which a `defmacr' + has been defined. + + `macroexpand' is similar to `macroexpand-1', but repeatedly + expands FORM until it is no longer a macro call. + + - Macro: defmacro NAME LAMBDA-LIST FORM ... + When encountered by `defmacro:eval', `defmacro:macroexpand*', or + `defmacro:load' defines a new macro which will henceforth be + expanded when encountered by `defmacro:eval', + `defmacro:macroexpand*', or `defmacro:load'. + +Defmacroexpand +-------------- + + `(require 'defmacroexpand)' + + - Function: defmacro:expand* E + Returns the result of expanding all defmacros in scheme expression + E. + + +File: slib.info, Node: R4RS Macros, Next: Macro by Example, Prev: Defmacro, Up: Macros + +R4RS Macros +=========== + + `(require 'macro)' is the appropriate call if you want R4RS +high-level macros but don't care about the low level implementation. If +an SLIB R4RS macro implementation is already loaded it will be used. +Otherwise, one of the R4RS macros implemetations is loaded. + + The SLIB R4RS macro implementations support the following uniform +interface: + + - Function: macro:expand SEXPRESSION + Takes an R4RS expression, macro-expands it, and returns the result + of the macro expansion. + + - Function: macro:eval SEXPRESSION + Takes an R4RS expression, macro-expands it, evals the result of the + macro expansion, and returns the result of the evaluation. + + - Procedure: macro:load FILENAME + FILENAME should be a string. If filename names an existing file, + the `macro:load' procedure reads Scheme source code expressions and + definitions from the file and evaluates them sequentially. These + source code expressions and definitions may contain macro + definitions. The `macro:load' procedure does not affect the + values returned by `current-input-port' and `current-output-port'. + + +File: slib.info, Node: Macro by Example, Next: Macros That Work, Prev: R4RS Macros, Up: Macros + +Macro by Example +================ + + `(require 'macro-by-example)' + + A vanilla implementation of `Macro by Example' (Eugene Kohlbecker, +R4RS) by Dorai Sitaram, (dorai@cs.rice.edu) using `defmacro'. + + * generating hygienic global `define-syntax' Macro-by-Example macros + *cheaply*. + + * can define macros which use `...'. + + * needn't worry about a lexical variable in a macro definition + clashing with a variable from the macro use context + + * don't suffer the overhead of redefining the repl if `defmacro' + natively supported (most implementations) + +Caveat +------ + + These macros are not referentially transparent (*note Macros: +(r4rs)Macros.). Lexically scoped macros (i.e., `let-syntax' and +`letrec-syntax') are not supported. In any case, the problem of +referential transparency gains poignancy only when `let-syntax' and +`letrec-syntax' are used. So you will not be courting large-scale +disaster unless you're using system-function names as local variables +with unintuitive bindings that the macro can't use. However, if you +must have the full `r4rs' macro functionality, look to the more +featureful (but also more expensive) versions of syntax-rules available +in slib *Note Macros That Work::, *Note Syntactic Closures::, and *Note +Syntax-Case Macros::. + + - Macro: define-syntax KEYWORD TRANSFORMER-SPEC + The KEYWORD is an identifier, and the TRANSFORMER-SPEC should be + an instance of `syntax-rules'. + + The top-level syntactic environment is extended by binding the + KEYWORD to the specified transformer. + + (define-syntax let* + (syntax-rules () + ((let* () body1 body2 ...) + (let () body1 body2 ...)) + ((let* ((name1 val1) (name2 val2) ...) + body1 body2 ...) + (let ((name1 val1)) + (let* (( name2 val2) ...) + body1 body2 ...))))) + + - Macro: syntax-rules LITERALS SYNTAX-RULE ... + LITERALS is a list of identifiers, and each SYNTAX-RULE should be + of the form + + `(PATTERN TEMPLATE)' + + where the PATTERN and TEMPLATE are as in the grammar above. + + An instance of `syntax-rules' produces a new macro transformer by + specifying a sequence of hygienic rewrite rules. A use of a macro + whose keyword is associated with a transformer specified by + `syntax-rules' is matched against the patterns contained in the + SYNTAX-RULEs, beginning with the leftmost SYNTAX-RULE. When a + match is found, the macro use is trancribed hygienically according + to the template. + + Each pattern begins with the keyword for the macro. This keyword + is not involved in the matching and is not considered a pattern + variable or literal identifier. + + +File: slib.info, Node: Macros That Work, Next: Syntactic Closures, Prev: Macro by Example, Up: Macros + +Macros That Work +================ + + `(require 'macros-that-work)' + + `Macros That Work' differs from the other R4RS macro implementations +in that it does not expand derived expression types to primitive +expression types. + + - Function: macro:expand EXPRESSION + - Function: macwork:expand EXPRESSION + Takes an R4RS expression, macro-expands it, and returns the result + of the macro expansion. + + - Function: macro:eval EXPRESSION + - Function: macwork:eval EXPRESSION + `macro:eval' returns the value of EXPRESSION in the current top + level environment. EXPRESSION can contain macro definitions. + Side effects of EXPRESSION will affect the top level environment. + + - Procedure: macro:load FILENAME + - Procedure: macwork:load FILENAME + FILENAME should be a string. If filename names an existing file, + the `macro:load' procedure reads Scheme source code expressions and + definitions from the file and evaluates them sequentially. These + source code expressions and definitions may contain macro + definitions. The `macro:load' procedure does not affect the + values returned by `current-input-port' and `current-output-port'. + + References: + + The `Revised^4 Report on the Algorithmic Language Scheme' Clinger and +Rees [editors]. To appear in LISP Pointers. Also available as a +technical report from the University of Oregon, MIT AI Lab, and Cornell. + + Macros That Work. Clinger and Rees. POPL '91. + + The supported syntax differs from the R4RS in that vectors are allowed +as patterns and as templates and are not allowed as pattern or template +data. + + transformer spec ==> (syntax-rules literals rules) + + rules ==> () + | (rule . rules) + + rule ==> (pattern template) + + pattern ==> pattern_var ; a symbol not in literals + | symbol ; a symbol in literals + | () + | (pattern . pattern) + | (ellipsis_pattern) + | #(pattern*) ; extends R4RS + | #(pattern* ellipsis_pattern) ; extends R4RS + | pattern_datum + + template ==> pattern_var + | symbol + | () + | (template2 . template2) + | #(template*) ; extends R4RS + | pattern_datum + + template2 ==> template + | ellipsis_template + + pattern_datum ==> string ; no vector + | character + | boolean + | number + + ellipsis_pattern ==> pattern ... + + ellipsis_template ==> template ... + + pattern_var ==> symbol ; not in literals + + literals ==> () + | (symbol . literals) + +Definitions +----------- + +Scope of an ellipsis + Within a pattern or template, the scope of an ellipsis (`...') is + the pattern or template that appears to its left. + +Rank of a pattern variable + The rank of a pattern variable is the number of ellipses within + whose scope it appears in the pattern. + +Rank of a subtemplate + The rank of a subtemplate is the number of ellipses within whose + scope it appears in the template. + +Template rank of an occurrence of a pattern variable + The template rank of an occurrence of a pattern variable within a + template is the rank of that occurrence, viewed as a subtemplate. + +Variables bound by a pattern + The variables bound by a pattern are the pattern variables that + appear within it. + +Referenced variables of a subtemplate + The referenced variables of a subtemplate are the pattern + variables that appear within it. + +Variables opened by an ellipsis template + The variables opened by an ellipsis template are the referenced + pattern variables whose rank is greater than the rank of the + ellipsis template. + +Restrictions +------------ + + No pattern variable appears more than once within a pattern. + + For every occurrence of a pattern variable within a template, the +template rank of the occurrence must be greater than or equal to the +pattern variable's rank. + + Every ellipsis template must open at least one variable. + + For every ellipsis template, the variables opened by an ellipsis +template must all be bound to sequences of the same length. + + The compiled form of a RULE is + + rule ==> (pattern template inserted) + + pattern ==> pattern_var + | symbol + | () + | (pattern . pattern) + | ellipsis_pattern + | #(pattern) + | pattern_datum + + template ==> pattern_var + | symbol + | () + | (template2 . template2) + | #(pattern) + | pattern_datum + + template2 ==> template + | ellipsis_template + + pattern_datum ==> string + | character + | boolean + | number + + pattern_var ==> #(V symbol rank) + + ellipsis_pattern ==> #(E pattern pattern_vars) + + ellipsis_template ==> #(E template pattern_vars) + + inserted ==> () + | (symbol . inserted) + + pattern_vars ==> () + | (pattern_var . pattern_vars) + + rank ==> exact non-negative integer + + where V and E are unforgeable values. + + The pattern variables associated with an ellipsis pattern are the +variables bound by the pattern, and the pattern variables associated +with an ellipsis template are the variables opened by the ellipsis +template. + + If the template contains a big chunk that contains no pattern +variables or inserted identifiers, then the big chunk will be copied +unnecessarily. That shouldn't matter very often. + diff --git a/slib.info-4 b/slib.info-4 new file mode 100644 index 0000000..3d3da19 --- /dev/null +++ b/slib.info-4 @@ -0,0 +1,1248 @@ +This is Info file slib.info, produced by Makeinfo-1.64 from the input +file slib.texi. + + This file documents SLIB, the portable Scheme library. + + Copyright (C) 1993 Todd R. Eigenschink Copyright (C) 1993, 1994, 1995 +Aubrey Jaffer + + Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + + Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + + Permission is granted to copy and distribute translations of this +manual into another language, under the above conditions for modified +versions, except that this permission notice may be stated in a +translation approved by the author. + + +File: slib.info, Node: Syntactic Closures, Next: Syntax-Case Macros, Prev: Macros That Work, Up: Macros + +Syntactic Closures +================== + + `(require 'syntactic-closures)' + + - Function: macro:expand EXPRESSION + - Function: synclo:expand EXPRESSION + Returns scheme code with the macros and derived expression types of + EXPRESSION expanded to primitive expression types. + + - Function: macro:eval EXPRESSION + - Function: synclo:eval EXPRESSION + `macro:eval' returns the value of EXPRESSION in the current top + level environment. EXPRESSION can contain macro definitions. + Side effects of EXPRESSION will affect the top level environment. + + - Procedure: macro:load FILENAME + - Procedure: synclo:load FILENAME + FILENAME should be a string. If filename names an existing file, + the `macro:load' procedure reads Scheme source code expressions and + definitions from the file and evaluates them sequentially. These + source code expressions and definitions may contain macro + definitions. The `macro:load' procedure does not affect the + values returned by `current-input-port' and `current-output-port'. + +Syntactic Closure Macro Facility +-------------------------------- + + A Syntactic Closures Macro Facility + + by Chris Hanson + + 9 November 1991 + + This document describes "syntactic closures", a low-level macro +facility for the Scheme programming language. The facility is an +alternative to the low-level macro facility described in the `Revised^4 +Report on Scheme.' This document is an addendum to that report. + + The syntactic closures facility extends the BNF rule for TRANSFORMER +SPEC to allow a new keyword that introduces a low-level macro +transformer: + TRANSFORMER SPEC := (transformer EXPRESSION) + + Additionally, the following procedures are added: + make-syntactic-closure + capture-syntactic-environment + identifier? + identifier=? + + The description of the facility is divided into three parts. The +first part defines basic terminology. The second part describes how +macro transformers are defined. The third part describes the use of +"identifiers", which extend the syntactic closure mechanism to be +compatible with `syntax-rules'. + +Terminology +........... + + This section defines the concepts and data types used by the syntactic +closures facility. + + "Forms" are the syntactic entities out of which programs are + recursively constructed. A form is any expression, any + definition, any syntactic keyword, or any syntactic closure. The + variable name that appears in a `set!' special form is also a + form. Examples of forms: + 17 + #t + car + (+ x 4) + (lambda (x) x) + (define pi 3.14159) + if + define + + An "alias" is an alternate name for a given symbol. It can appear + anywhere in a form that the symbol could be used, and when quoted + it is replaced by the symbol; however, it does not satisfy the + predicate `symbol?'. Macro transformers rarely distinguish + symbols from aliases, referring to both as identifiers. + + A "syntactic" environment maps identifiers to their meanings. + More precisely, it determines whether an identifier is a syntactic + keyword or a variable. If it is a keyword, the meaning is an + interpretation for the form in which that keyword appears. If it + is a variable, the meaning identifies which binding of that + variable is referenced. In short, syntactic environments contain + all of the contextual information necessary for interpreting the + meaning of a particular form. + + A "syntactic closure" consists of a form, a syntactic environment, + and a list of identifiers. All identifiers in the form take their + meaning from the syntactic environment, except those in the given + list. The identifiers in the list are to have their meanings + determined later. A syntactic closure may be used in any context + in which its form could have been used. Since a syntactic closure + is also a form, it may not be used in contexts where a form would + be illegal. For example, a form may not appear as a clause in the + cond special form. A syntactic closure appearing in a quoted + structure is replaced by its form. + +Transformer Definition +...................... + + This section describes the `transformer' special form and the +procedures `make-syntactic-closure' and `capture-syntactic-environment'. + + - Syntax: transformer EXPRESSION + Syntax: It is an error if this syntax occurs except as a + TRANSFORMER SPEC. + + Semantics: The EXPRESSION is evaluated in the standard transformer + environment to yield a macro transformer as described below. This + macro transformer is bound to a macro keyword by the special form + in which the `transformer' expression appears (for example, + `let-syntax'). + + A "macro transformer" is a procedure that takes two arguments, a + form and a syntactic environment, and returns a new form. The + first argument, the "input form", is the form in which the macro + keyword occurred. The second argument, the "usage environment", + is the syntactic environment in which the input form occurred. + The result of the transformer, the "output form", is automatically + closed in the "transformer environment", which is the syntactic + environment in which the `transformer' expression occurred. + + For example, here is a definition of a push macro using + `syntax-rules': + (define-syntax push + (syntax-rules () + ((push item list) + (set! list (cons item list))))) + + Here is an equivalent definition using `transformer': + (define-syntax push + (transformer + (lambda (exp env) + (let ((item + (make-syntactic-closure env '() (cadr exp))) + (list + (make-syntactic-closure env '() (caddr exp)))) + `(set! ,list (cons ,item ,list)))))) + + In this example, the identifiers `set!' and `cons' are closed in + the transformer environment, and thus will not be affected by the + meanings of those identifiers in the usage environment `env'. + + Some macros may be non-hygienic by design. For example, the + following defines a loop macro that implicitly binds `exit' to an + escape procedure. The binding of `exit' is intended to capture + free references to `exit' in the body of the loop, so `exit' must + be left free when the body is closed: + (define-syntax loop + (transformer + (lambda (exp env) + (let ((body (cdr exp))) + `(call-with-current-continuation + (lambda (exit) + (let f () + ,@(map (lambda (exp) + (make-syntactic-closure env '(exit) + exp)) + body) + (f)))))))) + + To assign meanings to the identifiers in a form, use + `make-syntactic-closure' to close the form in a syntactic + environment. + + - Function: make-syntactic-closure ENVIRONMENT FREE-NAMES FORM + ENVIRONMENT must be a syntactic environment, FREE-NAMES must be a + list of identifiers, and FORM must be a form. + `make-syntactic-closure' constructs and returns a syntactic closure + of FORM in ENVIRONMENT, which can be used anywhere that FORM could + have been used. All the identifiers used in FORM, except those + explicitly excepted by FREE-NAMES, obtain their meanings from + ENVIRONMENT. + + Here is an example where FREE-NAMES is something other than the + empty list. It is instructive to compare the use of FREE-NAMES in + this example with its use in the `loop' example above: the examples + are similar except for the source of the identifier being left + free. + (define-syntax let1 + (transformer + (lambda (exp env) + (let ((id (cadr exp)) + (init (caddr exp)) + (exp (cadddr exp))) + `((lambda (,id) + ,(make-syntactic-closure env (list id) exp)) + ,(make-syntactic-closure env '() init)))))) + + `let1' is a simplified version of `let' that only binds a single + identifier, and whose body consists of a single expression. When + the body expression is syntactically closed in its original + syntactic environment, the identifier that is to be bound by + `let1' must be left free, so that it can be properly captured by + the `lambda' in the output form. + + To obtain a syntactic environment other than the usage + environment, use `capture-syntactic-environment'. + + - Function: capture-syntactic-environment PROCEDURE + `capture-syntactic-environment' returns a form that will, when + transformed, call PROCEDURE on the current syntactic environment. + PROCEDURE should compute and return a new form to be transformed, + in that same syntactic environment, in place of the form. + + An example will make this clear. Suppose we wanted to define a + simple `loop-until' keyword equivalent to + (define-syntax loop-until + (syntax-rules () + ((loop-until id init test return step) + (letrec ((loop + (lambda (id) + (if test return (loop step))))) + (loop init))))) + + The following attempt at defining `loop-until' has a subtle bug: + (define-syntax loop-until + (transformer + (lambda (exp env) + (let ((id (cadr exp)) + (init (caddr exp)) + (test (cadddr exp)) + (return (cadddr (cdr exp))) + (step (cadddr (cddr exp))) + (close + (lambda (exp free) + (make-syntactic-closure env free exp)))) + `(letrec ((loop + (lambda (,id) + (if ,(close test (list id)) + ,(close return (list id)) + (loop ,(close step (list id))))))) + (loop ,(close init '()))))))) + + This definition appears to take all of the proper precautions to + prevent unintended captures. It carefully closes the + subexpressions in their original syntactic environment and it + leaves the `id' identifier free in the `test', `return', and + `step' expressions, so that it will be captured by the binding + introduced by the `lambda' expression. Unfortunately it uses the + identifiers `if' and `loop' within that `lambda' expression, so if + the user of `loop-until' just happens to use, say, `if' for the + identifier, it will be inadvertently captured. + + The syntactic environment that `if' and `loop' want to be exposed + to is the one just outside the `lambda' expression: before the + user's identifier is added to the syntactic environment, but after + the identifier loop has been added. + `capture-syntactic-environment' captures exactly that environment + as follows: + (define-syntax loop-until + (transformer + (lambda (exp env) + (let ((id (cadr exp)) + (init (caddr exp)) + (test (cadddr exp)) + (return (cadddr (cdr exp))) + (step (cadddr (cddr exp))) + (close + (lambda (exp free) + (make-syntactic-closure env free exp)))) + `(letrec ((loop + ,(capture-syntactic-environment + (lambda (env) + `(lambda (,id) + (,(make-syntactic-closure env '() `if) + ,(close test (list id)) + ,(close return (list id)) + (,(make-syntactic-closure env '() + `loop) + ,(close step (list id))))))))) + (loop ,(close init '()))))))) + + In this case, having captured the desired syntactic environment, + it is convenient to construct syntactic closures of the + identifiers `if' and the `loop' and use them in the body of the + `lambda'. + + A common use of `capture-syntactic-environment' is to get the + transformer environment of a macro transformer: + (transformer + (lambda (exp env) + (capture-syntactic-environment + (lambda (transformer-env) + ...)))) + +Identifiers +........... + + This section describes the procedures that create and manipulate +identifiers. Previous syntactic closure proposals did not have an +identifier data type - they just used symbols. The identifier data +type extends the syntactic closures facility to be compatible with the +high-level `syntax-rules' facility. + + As discussed earlier, an identifier is either a symbol or an "alias". +An alias is implemented as a syntactic closure whose "form" is an +identifier: + (make-syntactic-closure env '() 'a) + => an "alias" + + Aliases are implemented as syntactic closures because they behave just +like syntactic closures most of the time. The difference is that an +alias may be bound to a new value (for example by `lambda' or +`let-syntax'); other syntactic closures may not be used this way. If +an alias is bound, then within the scope of that binding it is looked +up in the syntactic environment just like any other identifier. + + Aliases are used in the implementation of the high-level facility +`syntax-rules'. A macro transformer created by `syntax-rules' uses a +template to generate its output form, substituting subforms of the +input form into the template. In a syntactic closures implementation, +all of the symbols in the template are replaced by aliases closed in +the transformer environment, while the output form itself is closed in +the usage environment. This guarantees that the macro transformation +is hygienic, without requiring the transformer to know the syntactic +roles of the substituted input subforms. + + - Function: identifier? OBJECT + Returns `#t' if OBJECT is an identifier, otherwise returns `#f'. + Examples: + (identifier? 'a) + => #t + (identifier? (make-syntactic-closure env '() 'a)) + => #t + (identifier? "a") + => #f + (identifier? #\a) + => #f + (identifier? 97) + => #f + (identifier? #f) + => #f + (identifier? '(a)) + => #f + (identifier? '#(a)) + => #f + + The predicate `eq?' is used to determine if two identifers are + "the same". Thus `eq?' can be used to compare identifiers exactly + as it would be used to compare symbols. Often, though, it is + useful to know whether two identifiers "mean the same thing". For + example, the `cond' macro uses the symbol `else' to identify the + final clause in the conditional. A macro transformer for `cond' + cannot just look for the symbol `else', because the `cond' form + might be the output of another macro transformer that replaced the + symbol `else' with an alias. Instead the transformer must look + for an identifier that "means the same thing" in the usage + environment as the symbol `else' means in the transformer + environment. + + - Function: identifier=? ENVIRONMENT1 IDENTIFIER1 ENVIRONMENT2 + IDENTIFIER2 + ENVIRONMENT1 and ENVIRONMENT2 must be syntactic environments, and + IDENTIFIER1 and IDENTIFIER2 must be identifiers. `identifier=?' + returns `#t' if the meaning of IDENTIFIER1 in ENVIRONMENT1 is the + same as that of IDENTIFIER2 in ENVIRONMENT2, otherwise it returns + `#f'. Examples: + + (let-syntax + ((foo + (transformer + (lambda (form env) + (capture-syntactic-environment + (lambda (transformer-env) + (identifier=? transformer-env 'x env 'x))))))) + (list (foo) + (let ((x 3)) + (foo)))) + => (#t #f) + + (let-syntax ((bar foo)) + (let-syntax + ((foo + (transformer + (lambda (form env) + (capture-syntactic-environment + (lambda (transformer-env) + (identifier=? transformer-env 'foo + env (cadr form)))))))) + (list (foo foo) + (foobar)))) + => (#f #t) + +Acknowledgements +................ + + The syntactic closures facility was invented by Alan Bawden and +Jonathan Rees. The use of aliases to implement `syntax-rules' was +invented by Alan Bawden (who prefers to call them "synthetic names"). +Much of this proposal is derived from an earlier proposal by Alan +Bawden. + + +File: slib.info, Node: Syntax-Case Macros, Next: Fluid-Let, Prev: Syntactic Closures, Up: Macros + +Syntax-Case Macros +================== + + `(require 'syntax-case)' + + - Function: macro:expand EXPRESSION + - Function: syncase:expand EXPRESSION + Returns scheme code with the macros and derived expression types of + EXPRESSION expanded to primitive expression types. + + - Function: macro:eval EXPRESSION + - Function: syncase:eval EXPRESSION + `macro:eval' returns the value of EXPRESSION in the current top + level environment. EXPRESSION can contain macro definitions. + Side effects of EXPRESSION will affect the top level environment. + + - Procedure: macro:load FILENAME + - Procedure: syncase:load FILENAME + FILENAME should be a string. If filename names an existing file, + the `macro:load' procedure reads Scheme source code expressions and + definitions from the file and evaluates them sequentially. These + source code expressions and definitions may contain macro + definitions. The `macro:load' procedure does not affect the + values returned by `current-input-port' and `current-output-port'. + + This is version 2.1 of `syntax-case', the low-level macro facility +proposed and implemented by Robert Hieb and R. Kent Dybvig. + + This version is further adapted by Harald Hanche-Olsen + to make it compatible with, and easily usable +with, SLIB. Mainly, these adaptations consisted of: + + * Removing white space from `expand.pp' to save space in the + distribution. This file is not meant for human readers anyway... + + * Removed a couple of Chez scheme dependencies. + + * Renamed global variables used to minimize the possibility of name + conflicts. + + * Adding an SLIB-specific initialization file. + + * Removing a couple extra files, most notably the documentation (but + see below). + + If you wish, you can see exactly what changes were done by reading the +shell script in the file `syncase.sh'. + + The two PostScript files were omitted in order to not burden the SLIB +distribution with them. If you do intend to use `syntax-case', +however, you should get these files and print them out on a PostScript +printer. They are available with the original `syntax-case' +distribution by anonymous FTP in +`cs.indiana.edu:/pub/scheme/syntax-case'. + + In order to use syntax-case from an interactive top level, execute: + (require 'syntax-case) + (require 'repl) + (repl:top-level macro:eval) + See the section Repl (*Note Repl::) for more information. + + To check operation of syntax-case get +`cs.indiana.edu:/pub/scheme/syntax-case', and type + (require 'syntax-case) + (syncase:sanity-check) + + Beware that `syntax-case' takes a long time to load - about 20s on a +SPARCstation SLC (with SCM) and about 90s on a Macintosh SE/30 (with +Gambit). + +Notes +----- + + All R4RS syntactic forms are defined, including `delay'. Along with +`delay' are simple definitions for `make-promise' (into which `delay' +expressions expand) and `force'. + + `syntax-rules' and `with-syntax' (described in `TR356') are defined. + + `syntax-case' is actually defined as a macro that expands into calls +to the procedure `syntax-dispatch' and the core form `syntax-lambda'; +do not redefine these names. + + Several other top-level bindings not documented in TR356 are created: + the "hooks" in `hooks.ss' + + the `build-' procedures in `output.ss' + + `expand-syntax' (the expander) + + The syntax of define has been extended to allow `(define ID)', which +assigns ID to some unspecified value. + + We have attempted to maintain R4RS compatibility where possible. The +incompatibilities should be confined to `hooks.ss'. Please let us know +if there is some incompatibility that is not flagged as such. + + Send bug reports, comments, suggestions, and questions to Kent Dybvig +(dyb@iuvax.cs.indiana.edu). + +Note from maintainer +-------------------- + + Included with the `syntax-case' files was `structure.scm' which +defines a macro `define-structure'. There is no documentation for this +macro and it is not used by any code in SLIB. + + +File: slib.info, Node: Fluid-Let, Next: Yasos, Prev: Syntax-Case Macros, Up: Macros + +Fluid-Let +========= + + `(require 'fluid-let)' + + - Syntax: fluid-let `(BINDINGS ...)' FORMS... + + (fluid-let ((VARIABLE INIT) ...) + EXPRESSION EXPRESSION ...) + + The INITs are evaluated in the current environment (in some +unspecified order), the current values of the VARIABLEs are saved, the +results are assigned to the VARIABLEs, the EXPRESSIONs are evaluated +sequentially in the current environment, the VARIABLEs are restored to +their original values, and the value of the last EXPRESSION is returned. + + The syntax of this special form is similar to that of `let', but +`fluid-let' temporarily rebinds existing VARIABLEs. Unlike `let', +`fluid-let' creates no new bindings; instead it *assigns* the values of +each INIT to the binding (determined by the rules of lexical scoping) +of its corresponding VARIABLE. + + +File: slib.info, Node: Yasos, Prev: Fluid-Let, Up: Macros + +Yasos +===== + + `(require 'oop)' or `(require 'yasos)' + + `Yet Another Scheme Object System' is a simple object system for +Scheme based on the paper by Norman Adams and Jonathan Rees: `Object +Oriented Programming in Scheme', Proceedings of the 1988 ACM Conference +on LISP and Functional Programming, July 1988 [ACM #552880]. + + Another reference is: + + Ken Dickey. Scheming with Objects `AI Expert' Volume 7, Number 10 +(October 1992), pp. 24-33. + +* Menu: + +* Yasos terms:: Definitions and disclaimer. +* Yasos interface:: The Yasos macros and procedures. +* Setters:: Dylan-like setters in Yasos. +* Yasos examples:: Usage of Yasos and setters. + + +File: slib.info, Node: Yasos terms, Next: Yasos interface, Prev: Yasos, Up: Yasos + +Terms +----- + +"Object" + Any Scheme data object. + +"Instance" + An instance of the OO system; an "object". + +"Operation" + A METHOD. + +*Notes:* + The object system supports multiple inheritance. An instance can + inherit from 0 or more ancestors. In the case of multiple + inherited operations with the same identity, the operation used is + that from the first ancestor which contains it (in the ancestor + `let'). An operation may be applied to any Scheme data + object--not just instances. As code which creates instances is + just code, there are no "classes" and no meta-ANYTHING. Method + dispatch is by a procedure call a la CLOS rather than by `send' + syntax a la Smalltalk. + +*Disclaimer:* + There are a number of optimizations which can be made. This + implementation is expository (although performance should be quite + reasonable). See the L&FP paper for some suggestions. + + +File: slib.info, Node: Yasos interface, Next: Setters, Prev: Yasos terms, Up: Yasos + +Interface +--------- + + - Syntax: define-operation `('OPNAME SELF ARG ...`)' DEFAULT-BODY + Defines a default behavior for data objects which don't handle the + operation OPNAME. The default default behavior (for an empty + DEFAULT-BODY) is to generate an error. + + - Syntax: define-predicate OPNAME? + Defines a predicate OPNAME?, usually used for determining the + "type" of an object, such that `(OPNAME? OBJECT)' returns `#t' if + OBJECT has an operation OPNAME? and `#f' otherwise. + + - Syntax: object `((NAME SELF ARG ...) BODY)' ... + Returns an object (an instance of the object system) with + operations. Invoking `(NAME OBJECT ARG ...' executes the BODY of + the OBJECT with SELF bound to OBJECT and with argument(s) ARG.... + + - Syntax: object-with-ancestors `(('ANCESTOR1 INIT1`)' ...`)' + OPERATION ... + A `let'-like form of `object' for multiple inheritance. It + returns an object inheriting the behaviour of ANCESTOR1 etc. An + operation will be invoked in an ancestor if the object itself does + not provide such a method. In the case of multiple inherited + operations with the same identity, the operation used is the one + found in the first ancestor in the ancestor list. + + - Syntax: operate-as COMPONENT OPERATION SELF ARG ... + Used in an operation definition (of SELF) to invoke the OPERATION + in an ancestor COMPONENT but maintain the object's identity. Also + known as "send-to-super". + + - Procedure: print OBJ PORT + A default `print' operation is provided which is just `(format + PORT OBJ)' (*Note Format::) for non-instances and prints OBJ + preceded by `#' for instances. + + - Function: size OBJ + The default method returns the number of elements in OBJ if it is + a vector, string or list, `2' for a pair, `1' for a character and + by default id an error otherwise. Objects such as collections + (*Note Collections::) may override the default in an obvious way. + + +File: slib.info, Node: Setters, Next: Yasos examples, Prev: Yasos interface, Up: Yasos + +Setters +------- + + "Setters" implement "generalized locations" for objects associated +with some sort of mutable state. A "getter" operation retrieves a +value from a generalized location and the corresponding setter +operation stores a value into the location. Only the getter is named - +the setter is specified by a procedure call as below. (Dylan uses +special syntax.) Typically, but not necessarily, getters are access +operations to extract values from Yasos objects (*Note Yasos::). +Several setters are predefined, corresponding to getters `car', `cdr', +`string-ref' and `vector-ref' e.g., `(setter car)' is equivalent to +`set-car!'. + + This implementation of setters is similar to that in Dylan(TM) +(`Dylan: An object-oriented dynamic language', Apple Computer Eastern +Research and Technology). Common LISP provides similar facilities +through `setf'. + + - Function: setter GETTER + Returns the setter for the procedure GETTER. E.g., since + `string-ref' is the getter corresponding to a setter which is + actually `string-set!': + (define foo "foo") + ((setter string-ref) foo 0 #\F) ; set element 0 of foo + foo => "Foo" + + - Syntax: set PLACE NEW-VALUE + If PLACE is a variable name, `set' is equivalent to `set!'. + Otherwise, PLACE must have the form of a procedure call, where the + procedure name refers to a getter and the call indicates an + accessible generalized location, i.e., the call would return a + value. The return value of `set' is usually unspecified unless + used with a setter whose definition guarantees to return a useful + value. + (set (string-ref foo 2) #\O) ; generalized location with getter + foo => "FoO" + (set foo "foo") ; like set! + foo => "foo" + + - Procedure: add-setter GETTER SETTER + Add procedures GETTER and SETTER to the (inaccessible) list of + valid setter/getter pairs. SETTER implements the store operation + corresponding to the GETTER access operation for the relevant + state. The return value is unspecified. + + - Procedure: remove-setter-for GETTER + Removes the setter corresponding to the specified GETTER from the + list of valid setters. The return value is unspecified. + + - Syntax: define-access-operation GETTER-NAME + Shorthand for a Yasos `define-operation' defining an operation + GETTER-NAME that objects may support to return the value of some + mutable state. The default operation is to signal an error. The + return value is unspecified. + + +File: slib.info, Node: Yasos examples, Prev: Setters, Up: Yasos + +Examples +-------- + + (define-operation (print obj port) + (format port + (if (instance? obj) "#" "~s") + obj)) + + (define-operation (SIZE obj) + (cond + ((vector? obj) (vector-length obj)) + ((list? obj) (length obj)) + ((pair? obj) 2) + ((string? obj) (string-length obj)) + ((char? obj) 1) + (else + (error "Operation not supported: size" obj)))) + + (define-predicate cell?) + (define-operation (fetch obj)) + (define-operation (store! obj newValue)) + + (define (make-cell value) + (object + ((cell? self) #t) + ((fetch self) value) + ((store! self newValue) + (set! value newValue) + newValue) + ((size self) 1) + ((print self port) + (format port "#" (fetch self))))) + + (define-operation (discard obj value) + (format #t "Discarding ~s~%" value)) + + (define (make-filtered-cell value filter) + (object-with-ancestors ((cell (make-cell value))) + ((store! self newValue) + (if (filter newValue) + (store! cell newValue) + (discard self newValue))))) + + (define-predicate array?) + (define-operation (array-ref array index)) + (define-operation (array-set! array index value)) + + (define (make-array num-slots) + (let ((anArray (make-vector num-slots))) + (object + ((array? self) #t) + ((size self) num-slots) + ((array-ref self index) (vector-ref anArray index)) + ((array-set! self index newValue) (vector-set! anArray index newValue)) + ((print self port) (format port "#" (size self)))))) + + (define-operation (position obj)) + (define-operation (discarded-value obj)) + + (define (make-cell-with-history value filter size) + (let ((pos 0) (most-recent-discard #f)) + (object-with-ancestors + ((cell (make-filtered-call value filter)) + (sequence (make-array size))) + ((array? self) #f) + ((position self) pos) + ((store! self newValue) + (operate-as cell store! self newValue) + (array-set! self pos newValue) + (set! pos (+ pos 1))) + ((discard self value) + (set! most-recent-discard value)) + ((discarded-value self) most-recent-discard) + ((print self port) + (format port "#" (fetch self)))))) + + (define-access-operation fetch) + (add-setter fetch store!) + (define foo (make-cell 1)) + (print foo #f) + => "#" + (set (fetch foo) 2) + => + (print foo #f) + => "#" + (fetch foo) + => 2 + + +File: slib.info, Node: Numerics, Next: Procedures, Prev: Macros, Up: Top + +Numerics +******** + +* Menu: + +* Bit-Twiddling:: 'logical +* Modular Arithmetic:: 'modular +* Prime Testing and Generation:: 'primes +* Prime Factorization:: 'factor +* Random Numbers:: 'random +* Cyclic Checksum:: 'make-crc +* Plotting:: 'charplot +* Root Finding:: + + +File: slib.info, Node: Bit-Twiddling, Next: Modular Arithmetic, Prev: Numerics, Up: Numerics + +Bit-Twiddling +============= + + `(require 'logical)' + + The bit-twiddling functions are made available through the use of the +`logical' package. `logical' is loaded by inserting `(require +'logical)' before the code that uses these functions. + + - Function: logand N1 N1 + Returns the integer which is the bit-wise AND of the two integer + arguments. + + Example: + (number->string (logand #b1100 #b1010) 2) + => "1000" + + - Function: logior N1 N2 + Returns the integer which is the bit-wise OR of the two integer + arguments. + + Example: + (number->string (logior #b1100 #b1010) 2) + => "1110" + + - Function: logxor N1 N2 + Returns the integer which is the bit-wise XOR of the two integer + arguments. + + Example: + (number->string (logxor #b1100 #b1010) 2) + => "110" + + - Function: lognot N + Returns the integer which is the 2s-complement of the integer + argument. + + Example: + (number->string (lognot #b10000000) 2) + => "-10000001" + (number->string (lognot #b0) 2) + => "-1" + + - Function: logtest J K + (logtest j k) == (not (zero? (logand j k))) + + (logtest #b0100 #b1011) => #f + (logtest #b0100 #b0111) => #t + + - Function: logbit? INDEX J + (logbit? index j) == (logtest (integer-expt 2 index) j) + + (logbit? 0 #b1101) => #t + (logbit? 1 #b1101) => #f + (logbit? 2 #b1101) => #t + (logbit? 3 #b1101) => #t + (logbit? 4 #b1101) => #f + + - Function: ash INT COUNT + Returns an integer equivalent to `(inexact->exact (floor (* INT + (expt 2 COUNT))))'. + + Example: + (number->string (ash #b1 3) 2) + => "1000" + (number->string (ash #b1010 -1) 2) + => "101" + + - Function: logcount N + Returns the number of bits in integer N. If integer is positive, + the 1-bits in its binary representation are counted. If negative, + the 0-bits in its two's-complement binary representation are + counted. If 0, 0 is returned. + + Example: + (logcount #b10101010) + => 4 + (logcount 0) + => 0 + (logcount -2) + => 1 + + - Function: integer-length N + Returns the number of bits neccessary to represent N. + + Example: + (integer-length #b10101010) + => 8 + (integer-length 0) + => 0 + (integer-length #b1111) + => 4 + + - Function: integer-expt N K + Returns N raised to the non-negative integer exponent K. + + Example: + (integer-expt 2 5) + => 32 + (integer-expt -3 3) + => -27 + + - Function: bit-extract N START END + Returns the integer composed of the START (inclusive) through END + (exclusive) bits of N. The STARTth bit becomes the 0-th bit in + the result. + + Example: + (number->string (bit-extract #b1101101010 0 4) 2) + => "1010" + (number->string (bit-extract #b1101101010 4 9) 2) + => "10110" + + +File: slib.info, Node: Modular Arithmetic, Next: Prime Testing and Generation, Prev: Bit-Twiddling, Up: Numerics + +Modular Arithmetic +================== + + `(require 'modular)' + + - Function: extended-euclid N1 N2 + Returns a list of 3 integers `(d x y)' such that d = gcd(N1, N2) = + N1 * x + N2 * y. + + - Function: symmetric:modulus N + Returns `(quotient (+ -1 n) -2)' for positive odd integer N. + + - Function: modulus->integer MODULUS + Returns the non-negative integer characteristic of the ring formed + when MODULUS is used with `modular:' procedures. + + - Function: modular:normalize MODULUS N + Returns the integer `(modulo N (modulus->integer MODULUS))' in the + representation specified by MODULUS. + +The rest of these functions assume normalized arguments; That is, the +arguments are constrained by the following table: + +For all of these functions, if the first argument (MODULUS) is: +`positive?' + Work as before. The result is between 0 and MODULUS. + +`zero?' + The arguments are treated as integers. An integer is returned. + +`negative?' + The arguments and result are treated as members of the integers + modulo `(+ 1 (* -2 MODULUS))', but with "symmetric" + representation; i.e. `(<= (- MODULUS) N MODULUS)'. + +If all the arguments are fixnums the computation will use only fixnums. + + - Function: modular:invertable? MODULUS K + Returns `#t' if there exists an integer n such that K * n == 1 mod + MODULUS, and `#f' otherwise. + + - Function: modular:invert MODULUS K2 + Returns an integer n such that 1 = (n * K2) mod MODULUS. If K2 + has no inverse mod MODULUS an error is signaled. + + - Function: modular:negate MODULUS K2 + Returns (-K2) mod MODULUS. + + - Function: modular:+ MODULUS K2 K3 + Returns (K2 + K3) mod MODULUS. + + - Function: modular:- MODULUS K2 K3 + Returns (K2 - K3) mod MODULUS. + + - Function: modular:* MODULUS K2 K3 + Returns (K2 * K3) mod MODULUS. + + The Scheme code for `modular:*' with negative MODULUS is not + completed for fixnum-only implementations. + + - Function: modular:expt MODULUS K2 K3 + Returns (K2 ^ K3) mod MODULUS. + + +File: slib.info, Node: Prime Testing and Generation, Next: Prime Factorization, Prev: Modular Arithmetic, Up: Numerics + +Prime Testing and Generation +============================ + + `(require 'primes)' + + This package tests and generates prime numbers. The strategy used is +as follows: + + First, use trial division by small primes (primes less than 1000) + to quickly weed out composites with small factors. As a side + benefit, this makes the test precise for numbers up to one million. + + Second, apply the Miller-Rabin primality test to detect (with high + probability) any remaining composites. + + The Miller-Rabin test is a Monte-Carlo test--in other words, it's fast +and it gets the right answer with high probability. For a candidate +that *is* prime, the Miller-Rabin test is certain to report "prime"; it +will never report "composite". However, for a candidate that is +composite, there is a (small) probability that the Miller-Rabin test +will erroneously report "prime". This probability can be made +arbitarily small by adjusting the number of iterations of the +Miller-Rabin test. + + - Function: probably-prime? CANDIDATE + - Function: probably-prime? CANDIDATE ITER + Returns `#t' if `candidate' is probably prime. The optional + parameter `iter' controls the number of iterations of the + Miller-Rabin test. The probability of a composite candidate being + mistaken for a prime is at most `(1/4)^iter'. The default value of + `iter' is 15, which makes the probability less than 1 in 10^9. + + + - Function: primes< START COUNT + - Function: primes< START COUNT ITER + - Function: primes> START COUNT + - Function: primes> START COUNT ITER + Returns a list of the first `count' odd probable primes less (more) + than or equal to `start'. The optional parameter `iter' controls + the number of iterations of the Miller-Rabin test for each + candidate. The probability of a composite candidate being + mistaken for a prime is at most `(1/4)^iter'. The default value + of `iter' is 15, which makes the probability less than 1 in 10^9. + + +* Menu: + +* The Miller-Rabin Test:: How the Miller-Rabin test works + + +File: slib.info, Node: The Miller-Rabin Test, Prev: Prime Testing and Generation, Up: Prime Testing and Generation + +Theory +------ + + Rabin and Miller's result can be summarized as follows. Let `p' (the +candidate prime) be any odd integer greater than 2. Let `b' (the +"base") be an integer in the range `2 ... p-1'. There is a fairly +simple Boolean function--call it `C', for "Composite"--with the +following properties: + If `p' is prime, `C(p, b)' is false for all `b' in the range `2 + ... p-1'. + + If `p' is composite, `C(p, b)' is false for at most 1/4 of all `b' + in the range ` 2 ... p-1'. (If the test fails for base `b', `p' + is called a *strong pseudo-prime to base `b'*.) + + For details of `C', and why it fails for at most 1/4 of the potential +bases, please consult a book on number theory or cryptography such as +"A Course in Number Theory and Cryptography" by Neal Koblitz, published +by Springer-Verlag 1994. + + There is nothing probablistic about this result. It's true for all +`p'. If we had time to test `(1/4)p + 1' different bases, we could +definitively determine the primality of `p'. For large candidates, +that would take much too long--much longer than the simple approach of +dividing by all numbers up to `sqrt(p)'. This is where probability +enters the picture. + + Suppose we have some candidate prime `p'. Pick a random integer `b' +in the range `2 ... p-1'. Compute `C(p,b)'. If `p' is prime, the +result will certainly be false. If `p' is composite, the probability +is at most 1/4 that the result will be false (demonstrating that `p' is +a strong pseudoprime to base `b'). The test can be repeated with other +random bases. If `p' is prime, each test is certain to return false. +If `p' is composite, the probability of `C(p,b)' returning false is at +most 1/4 for each test. Since the `b' are chosen at random, the tests +outcomes are independent. So if `p' is composite and the test is +repeated, say, 15 times, the probability of it returning false all +fifteen times is at most (1/4)^15, or about 10^-9. If the test is +repeated 30 times, the probability of failure drops to at most 8.3e-25. + + Rabin and Miller's result holds for *all* candidates `p'. However, +if the candidate `p' is picked at random, the probability of the +Miller-Rabin test failing is much less than the computed bound. This +is because, for *most* composite numbers, the fraction of bases that +cause the test to fail is much less than 1/4. For example, if you pick +a random odd number less than 1000 and apply the Miller-Rabin test with +only 3 random bases, the computed failure bound is (1/4)^3, or about +1.6e-2. However, the actual probability of failure is much less--about +7.2e-5. If you accidentally pick 703 to test for primality, the +probability of failure is (161/703)^3, or about 1.2e-2, which is almost +as high as the computed bound. This is because 703 is a strong +pseudoprime to 161 bases. But if you pick at random there is only a +small chance of picking 703, and no other number less than 1000 has +that high a percentage of pseudoprime bases. + + The Miller-Rabin test is sometimes used in a slightly different +fashion, where it can, at least in principle, cause problems. The +weaker version uses small prime bases instead of random bases. If you +are picking candidates at random and testing for primality, this works +well since very few composites are strong pseudo-primes to small prime +bases. (For example, there is only one composite less than 2.5e10 that +is a strong pseudo-prime to the bases 2, 3, 5, and 7.) The problem +with this approach is that once a candidate has been picked, the test is +deterministic. This distinction is subtle, but real. With the +randomized test, for *any* candidate you pick--even if your +candidate-picking procedure is strongly biased towards troublesome +numbers, the test will work with high probability. With the +deterministic version, for any particular candidate, the test will +either work (with probability 1), or fail (with probability 1). It +won't fail for very many candidates, but that won't be much consolation +if your candidate-picking procedure is somehow biased toward troublesome +numbers. + + +File: slib.info, Node: Prime Factorization, Next: Random Numbers, Prev: Prime Testing and Generation, Up: Numerics + +Prime Factorization +=================== + + `(require 'factor)' + + - Function: factor K + Returns a list of the prime factors of K. The order of the + factors is unspecified. In order to obtain a sorted list do + `(sort! (factor k) <)'. + + *Note:* The rest of these procedures implement the Solovay-Strassen +primality test. This test has been superseeded by the faster *Note +probably-prime?: Prime Testing and Generation. However these are left +here as they take up little space and may be of use to an +implementation without bignums. + + See Robert Solovay and Volker Strassen, `A Fast Monte-Carlo Test for +Primality', SIAM Journal on Computing, 1977, pp 84-85. + + - Function: jacobi-symbol P Q + Returns the value (+1, -1, or 0) of the Jacobi-Symbol of exact + non-negative integer P and exact positive odd integer Q. + + - Function: prime? P + Returns `#f' if P is composite; `#t' if P is prime. There is a + slight chance `(expt 2 (- prime:trials))' that a composite will + return `#t'. + + - Function: prime:trials + Is the maxinum number of iterations of Solovay-Strassen that will + be done to test a number for primality. + + +File: slib.info, Node: Random Numbers, Next: Cyclic Checksum, Prev: Prime Factorization, Up: Numerics + +Random Numbers +============== + + `(require 'random)' + + - Procedure: random N + - Procedure: random N STATE + Accepts a positive integer or real N and returns a number of the + same type between zero (inclusive) and N (exclusive). The values + returned have a uniform distribution. + + The optional argument STATE must be of the type produced by + `(make-random-state)'. It defaults to the value of the variable + `*random-state*'. This object is used to maintain the state of the + pseudo-random-number generator and is altered as a side effect of + the `random' operation. + + - Variable: *random-state* + Holds a data structure that encodes the internal state of the + random-number generator that `random' uses by default. The nature + of this data structure is implementation-dependent. It may be + printed out and successfully read back in, but may or may not + function correctly as a random-number state object in another + implementation. + + - Procedure: make-random-state + - Procedure: make-random-state STATE + Returns a new object of type suitable for use as the value of the + variable `*random-state*' and as a second argument to `random'. + If argument STATE is given, a copy of it is returned. Otherwise a + copy of `*random-state*' is returned. + + If inexact numbers are support by the Scheme implementation, +`randinex.scm' will be loaded as well. `randinex.scm' contains +procedures for generating inexact distributions. + + - Procedure: random:uniform STATE + Returns an uniformly distributed inexact real random number in the + range between 0 and 1. + + - Procedure: random:solid-sphere! VECT + - Procedure: random:solid-sphere! VECT STATE + Fills VECT with inexact real random numbers the sum of whose + squares is less than 1.0. Thinking of VECT as coordinates in + space of dimension N = `(vector-length VECT)', the coordinates are + uniformly distributed within the unit N-shere. The sum of the + squares of the numbers is returned. + + - Procedure: random:hollow-sphere! VECT + - Procedure: random:hollow-sphere! VECT STATE + Fills VECT with inexact real random numbers the sum of whose + squares is equal to 1.0. Thinking of VECT as coordinates in space + of dimension n = `(vector-length VECT)', the coordinates are + uniformly distributed over the surface of the unit n-shere. + + - Procedure: random:normal + - Procedure: random:normal STATE + Returns an inexact real in a normal distribution with mean 0 and + standard deviation 1. For a normal distribution with mean M and + standard deviation D use `(+ M (* D (random:normal)))'. + + - Procedure: random:normal-vector! VECT + - Procedure: random:normal-vector! VECT STATE + Fills VECT with inexact real random numbers which are independent + and standard normally distributed (i.e., with mean 0 and variance + 1). + + - Procedure: random:exp + - Procedure: random:exp STATE + Returns an inexact real in an exponential distribution with mean + 1. For an exponential distribution with mean U use (* U + (random:exp)). + diff --git a/slib.info-5 b/slib.info-5 new file mode 100644 index 0000000..04d1b28 --- /dev/null +++ b/slib.info-5 @@ -0,0 +1,1536 @@ +This is Info file slib.info, produced by Makeinfo-1.64 from the input +file slib.texi. + + This file documents SLIB, the portable Scheme library. + + Copyright (C) 1993 Todd R. Eigenschink Copyright (C) 1993, 1994, 1995 +Aubrey Jaffer + + Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + + Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + + Permission is granted to copy and distribute translations of this +manual into another language, under the above conditions for modified +versions, except that this permission notice may be stated in a +translation approved by the author. + + +File: slib.info, Node: Cyclic Checksum, Next: Plotting, Prev: Random Numbers, Up: Numerics + +Cyclic Checksum +=============== + + `(require 'make-crc)' + + - Function: make-port-crc + - Function: make-port-crc DEGREE + - Function: make-port-crc DEGREE GENERATOR + Returns an expression for a procedure of one argument, a port. + This procedure reads characters from the port until the end of + file and returns the integer checksum of the bytes read. + + The integer DEGREE, if given, specifies the degree of the + polynomial being computed - which is also the number of bits + computed in the checksums. The default value is 32. + + The integer GENERATOR specifies the polynomial being computed. + The power of 2 generating each 1 bit is the exponent of a term of + the polynomial. The bit at position DEGREE is implicit and should + not be part of GENERATOR. This allows systems with numbers + limited to 32 bits to calculate 32 bit checksums. The default + value of GENERATOR when DEGREE is 32 (its default) is: + + (make-port-crc 32 #b00000100110000010001110110110111) + + Creates a procedure to calculate the P1003.2/D11.2 (POSIX.2) 32-bit + checksum from the polynomial: + + 32 26 23 22 16 12 11 + ( x + x + x + x + x + x + x + + + 10 8 7 5 4 2 1 + x + x + x + x + x + x + x + 1 ) mod 2 + + (require 'make-crc) + (define crc32 (slib:eval (make-port-crc))) + (define (file-check-sum file) (call-with-input-file file crc32)) + (file-check-sum (in-vicinity (library-vicinity) "ratize.scm")) + + => 3553047446 + + +File: slib.info, Node: Plotting, Next: Root Finding, Prev: Cyclic Checksum, Up: Numerics + +Plotting on Character Devices +============================= + + `(require 'charplot)' + + The plotting procedure is made available through the use of the +`charplot' package. `charplot' is loaded by inserting `(require +'charplot)' before the code that uses this procedure. + + - Variable: charplot:height + The number of rows to make the plot vertically. + + - Variable: charplot:width + The number of columns to make the plot horizontally. + + - Procedure: plot! COORDS X-LABEL Y-LABEL + COORDS is a list of pairs of x and y coordinates. X-LABEL and + Y-LABEL are strings with which to label the x and y axes. + + Example: + (require 'charplot) + (set! charplot:height 19) + (set! charplot:width 45) + + (define (make-points n) + (if (zero? n) + '() + (cons (cons (/ n 6) (sin (/ n 6))) (make-points (1- n))))) + + (plot! (make-points 37) "x" "Sin(x)") + -| + Sin(x) ______________________________________________ + 1.25|- | + | | + 1|- **** | + | ** ** | + 750.0e-3|- * * | + | * * | + 500.0e-3|- * * | + | * | + 250.0e-3|- * | + | * * | + 0|-------------------*--------------------------| + | * | + -250.0e-3|- * * | + | * * | + -500.0e-3|- * | + | * * | + -750.0e-3|- * * | + | ** ** | + -1|- **** | + |____________:_____._____:_____._____:_________| + x 2 4 + + +File: slib.info, Node: Root Finding, Prev: Plotting, Up: Numerics + +Root Finding +============ + + `(require 'root)' + + - Function: newtown:find-integer-root F DF/DX X0 + Given integer valued procedure F, its derivative (with respect to + its argument) DF/DX, and initial integer value X0 for which + DF/DX(X0) is non-zero, returns an integer X for which F(X) is + closer to zero than either of the integers adjacent to X; or + returns `#f' if such an integer can't be found. + + To find the closest integer to a given integers square root: + + (define (integer-sqrt y) + (newton:find-integer-root + (lambda (x) (- (* x x) y)) + (lambda (x) (* 2 x)) + (ash 1 (quotient (integer-length y) 2)))) + + (integer-sqrt 15) => 4 + + - Function: integer-sqrt Y + Given a non-negative integer Y, returns the rounded square-root of + Y. + + - Function: newton:find-root F DF/DX X0 PREC + Given real valued procedures F, DF/DX of one (real) argument, + initial real value X0 for which DF/DX(X0) is non-zero, and + positive real number PREC, returns a real X for which `abs'(F(X)) + is less than PREC; or returns `#f' if such a real can't be found. + + If `prec' is instead a negative integer, `newton:find-root' + returns the result of -PREC iterations. + +H. J. Orchard, `The Laguerre Method for Finding the Zeros of +Polynomials', IEEE Transactions on Circuits and Systems, Vol. 36, No. +11, November 1989, pp 1377-1381. + + There are 2 errors in Orchard's Table II. Line k=2 for starting + value of 1000+j0 should have Z_k of 1.0475 + j4.1036 and line k=2 + for starting value of 0+j1000 should have Z_k of 1.0988 + j4.0833. + + - Function: laguerre:find-root F DF/DZ DDF/DZ^2 Z0 PREC + Given complex valued procedure F of one (complex) argument, its + derivative (with respect to its argument) DF/DX, its second + derivative DDF/DZ^2, initial complex value Z0, and positive real + number PREC, returns a complex number Z for which + `magnitude'(F(Z)) is less than PREC; or returns `#f' if such a + number can't be found. + + If `prec' is instead a negative integer, `laguerre:find-root' + returns the result of -PREC iterations. + + - Function: laguerre:find-polynomial-root DEG F DF/DZ DDF/DZ^2 Z0 PREC + Given polynomial procedure F of integer degree DEG of one + argument, its derivative (with respect to its argument) DF/DX, its + second derivative DDF/DZ^2, initial complex value Z0, and positive + real number PREC, returns a complex number Z for which + `magnitude'(F(Z)) is less than PREC; or returns `#f' if such a + number can't be found. + + If `prec' is instead a negative integer, + `laguerre:find-polynomial-root' returns the result of -PREC + iterations. + + +File: slib.info, Node: Procedures, Next: Standards Support, Prev: Numerics, Up: Top + +Procedures +********** + + Anything that doesn't fall neatly into any of the other categories +winds up here. + +* Menu: + +* Batch:: 'batch +* Common List Functions:: 'common-list-functions +* Format:: 'format +* Generic-Write:: 'generic-write +* Line I/O:: 'line-i/o +* Multi-Processing:: 'process +* Object-To-String:: 'object->string +* Pretty-Print:: 'pretty-print, 'pprint-file +* Sorting:: 'sort +* Topological Sort:: +* Standard Formatted I/O:: 'printf, 'scanf +* String-Case:: 'string-case +* String Ports:: 'string-port +* String Search:: +* Tektronix Graphics Support:: +* Tree Operations:: 'tree + + +File: slib.info, Node: Batch, Next: Common List Functions, Prev: Procedures, Up: Procedures + +Batch +===== + + `(require 'batch)' + +The batch procedures provide a way to write and execute portable scripts +for a variety of operating systems. Each `batch:' procedure takes as +its first argument a parameter-list (*note Parameter lists::.). This +parameter-list argument PARMS contains named associations. Batch +currently uses 2 of these: + +`batch-port' + The port on which to write lines of the batch file. + +`batch-dialect' + The syntax of batch file to generate. Currently supported are: + * unix + + * dos + + * vms + + * system + + * *unknown* + +`batch.scm' uses 2 enhanced relational tables (*note Database +Utilities::.) to store information linking the names of +`operating-system's to `batch-dialect'es. + + - Function: batch:initialize! DATABASE + Defines `operating-system' and `batch-dialect' tables and adds the + domain `operating-system' to the enhanced relational database + DATABASE. + + - Variable: batch:platform + Is batch's best guess as to which operating-system it is running + under. `batch:platform' is set to `(software-type)' (*note + Configuration::.) unless `(software-type)' is `unix', in which + case finer distinctions are made. + + - Function: batch:call-with-output-script PARMS FILE PROC + PROC should be a procedure of one argument. If FILE is an + output-port, `batch:call-with-output-script' writes an appropriate + header to FILE and then calls PROC with FILE as the only argument. + If FILE is a string, `batch:call-with-output-script' opens a + output-file of name FILE, writes an appropriate header to FILE, + and then calls PROC with the newly opened port as the only + argument. Otherwise, `batch:call-with-output-script' acts as if + it was called with the result of `(current-output-port)' as its + third argument. + + - Function: batch:apply-chop-to-fit PROC ARG1 ARG2 ... LIST + The procedure PROC must accept at least one argument and return + `#t' if successful, `#f' if not. `batch:apply-chop-to-fit' calls + PROC with ARG1, ARG2, ..., and CHUNK, where CHUNK is a subset of + LIST. `batch:apply-chop-to-fit' tries PROC with successively + smaller subsets of LIST until either PROC returns non-false, or + the CHUNKs become empty. + +The rest of the `batch:' procedures write (or execute if +`batch-dialect' is `system') commands to the batch port which has been +added to PARMS or `(copy-tree PARMS)' by the code: + + (adjoin-parameters! PARMS (list 'batch-port PORT)) + + - Function: batch:system PARMS STRING1 STRING2 ... + Calls `batch:try-system' (below) with arguments, but signals an + error if `batch:try-system' returns `#f'. + +These functions return a non-false value if the command was successfully +translated into the batch dialect and `#f' if not. In the case of the +`system' dialect, the value is non-false if the operation suceeded. + + - Function: batch:try-system PARMS STRING1 STRING2 ... + Writes a command to the `batch-port' in PARMS which executes the + program named STRING1 with arguments STRING2 .... + + - Function: batch:run-script PARMS STRING1 STRING2 ... + Writes a command to the `batch-port' in PARMS which executes the + batch script named STRING1 with arguments STRING2 .... + + *Note:* `batch:run-script' and `batch:try-system' are not the same + for some operating systems (VMS). + + - Function: batch:comment PARMS LINE1 ... + Writes comment lines LINE1 ... to the `batch-port' in PARMS. + + - Function: batch:lines->file PARMS FILE LINE1 ... + Writes commands to the `batch-port' in PARMS which create a file + named FILE with contents LINE1 .... + + - Function: batch:delete-file PARMS FILE + Writes a command to the `batch-port' in PARMS which deletes the + file named FILE. + + - Function: batch:rename-file PARMS OLD-NAME NEW-NAME + Writes a command to the `batch-port' in PARMS which renames the + file OLD-NAME to NEW-NAME. + +In addition, batch provides some small utilities very useful for writing +scripts: + + - Function: replace-suffix STR OLD NEW + Returns a new string similar to `str' but with the suffix string + OLD removed and the suffix string NEW appended. If the end of STR + does not match OLD, an error is signaled. + + - Function: string-join JOINER STRING1 ... + Returns a new string consisting of all the strings STRING1 ... in + order appended together with the string JOINER between each + adjacent pair. + + - Function: must-be-first LIST1 LIST2 + Returns a new list consisting of the elements of LIST2 ordered so + that if some elements of LIST1 are `equal?' to elements of LIST2, + then those elements will appear first and in the order of LIST1. + + - Function: must-be-last LIST1 LIST2 + Returns a new list consisting of the elements of LIST1 ordered so + that if some elements of LIST2 are `equal?' to elements of LIST1, + then those elements will appear last and in the order of LIST2. + + - Function: os->batch-dialect OSNAME + Returns its best guess for the `batch-dialect' to be used for the + operating-system named OSNAME. `os->batch-dialect' uses the + tables added to DATABASE by `batch:initialize!'. + +Here is an example of the use of most of batch's procedures: + + (require 'database-utilities) + (require 'parameters) + (require 'batch) + + (define batch (create-database #f 'alist-table)) + (batch:initialize! batch) + + (define my-parameters + (list (list 'batch-dialect (os->batch-dialect batch:platform)) + (list 'platform batch:platform) + (list 'batch-port (current-output-port)))) ;gets filled in later + + (batch:call-with-output-script + my-parameters + "my-batch" + (lambda (batch-port) + (adjoin-parameters! my-parameters (list 'batch-port batch-port)) + (and + (batch:comment my-parameters + "================ Write file with C program.") + (batch:rename-file my-parameters "hello.c" "hello.c~") + (batch:lines->file my-parameters "hello.c" + "#include " + "int main(int argc, char **argv)" + "{" + " printf(\"hello world\\n\");" + " return 0;" + "}" ) + (batch:system my-parameters "cc" "-c" "hello.c") + (batch:system my-parameters "cc" "-o" "hello" + (replace-suffix "hello.c" ".c" ".o")) + (batch:system my-parameters "hello") + (batch:delete-file my-parameters "hello") + (batch:delete-file my-parameters "hello.c") + (batch:delete-file my-parameters "hello.o") + (batch:delete-file my-parameters "my-batch") + ))) + +Produces the file `my-batch': + + #!/bin/sh + # "my-batch" build script created Sat Jun 10 21:20:37 1995 + # ================ Write file with C program. + mv -f hello.c hello.c~ + rm -f hello.c + echo '#include '>>hello.c + echo 'int main(int argc, char **argv)'>>hello.c + echo '{'>>hello.c + echo ' printf("hello world\n");'>>hello.c + echo ' return 0;'>>hello.c + echo '}'>>hello.c + cc -c hello.c + cc -o hello hello.o + hello + rm -f hello + rm -f hello.c + rm -f hello.o + rm -f my-batch + +When run, `my-batch' prints: + + bash$ my-batch + mv: hello.c: No such file or directory + hello world + + +File: slib.info, Node: Common List Functions, Next: Format, Prev: Batch, Up: Procedures + +Common List Functions +===================== + + `(require 'common-list-functions)' + + The procedures below follow the Common LISP equivalents apart from +optional arguments in some cases. + +* Menu: + +* List construction:: +* Lists as sets:: +* Lists as sequences:: +* Destructive list operations:: +* Non-List functions:: + + +File: slib.info, Node: List construction, Next: Lists as sets, Prev: Common List Functions, Up: Common List Functions + +List construction +----------------- + + - Function: make-list K . INIT + `make-list' creates and returns a list of K elements. If INIT is + included, all elements in the list are initialized to INIT. + + Example: + (make-list 3) + => (# # #) + (make-list 5 'foo) + => (foo foo foo foo foo) + + - Function: list* X . Y + Works like `list' except that the cdr of the last pair is the last + argument unless there is only one argument, when the result is + just that argument. Sometimes called `cons*'. E.g.: + (list* 1) + => 1 + (list* 1 2 3) + => (1 2 . 3) + (list* 1 2 '(3 4)) + => (1 2 3 4) + (list* ARGS '()) + == (list ARGS) + + - Function: copy-list LST + `copy-list' makes a copy of LST using new pairs and returns it. + Only the top level of the list is copied, i.e., pairs forming + elements of the copied list remain `eq?' to the corresponding + elements of the original; the copy is, however, not `eq?' to the + original, but is `equal?' to it. + + Example: + (copy-list '(foo foo foo)) + => (foo foo foo) + (define q '(foo bar baz bang)) + (define p q) + (eq? p q) + => #t + (define r (copy-list q)) + (eq? q r) + => #f + (equal? q r) + => #t + (define bar '(bar)) + (eq? bar (car (copy-list (list bar 'foo)))) + => #t + + +File: slib.info, Node: Lists as sets, Next: Lists as sequences, Prev: List construction, Up: Common List Functions + +Lists as sets +------------- + + `eq?' is used to test for membership by all the procedures below +which treat lists as sets. + + - Function: adjoin E L + `adjoin' returns the adjoint of the element E and the list L. + That is, if E is in L, `adjoin' returns L, otherwise, it returns + `(cons E L)'. + + Example: + (adjoin 'baz '(bar baz bang)) + => (bar baz bang) + (adjoin 'foo '(bar baz bang)) + => (foo bar baz bang) + + - Function: union L1 L2 + `union' returns the combination of L1 and L2. Duplicates between + L1 and L2 are culled. Duplicates within L1 or within L2 may or + may not be removed. + + Example: + (union '(1 2 3 4) '(5 6 7 8)) + => (4 3 2 1 5 6 7 8) + (union '(1 2 3 4) '(3 4 5 6)) + => (2 1 3 4 5 6) + + - Function: intersection L1 L2 + `intersection' returns all elements that are in both L1 and L2. + + Example: + (intersection '(1 2 3 4) '(3 4 5 6)) + => (3 4) + (intersection '(1 2 3 4) '(5 6 7 8)) + => () + + - Function: set-difference L1 L2 + `set-difference' returns the union of all elements that are in L1 + but not in L2. + + Example: + (set-difference '(1 2 3 4) '(3 4 5 6)) + => (1 2) + (set-difference '(1 2 3 4) '(1 2 3 4 5 6)) + => () + + - Function: member-if PRED LST + `member-if' returns LST if `(PRED ELEMENT)' is `#t' for any + ELEMENT in LST. Returns `#f' if PRED does not apply to any + ELEMENT in LST. + + Example: + (member-if vector? '(1 2 3 4)) + => #f + (member-if number? '(1 2 3 4)) + => (1 2 3 4) + + - Function: some PRED LST . MORE-LSTS + PRED is a boolean function of as many arguments as there are list + arguments to `some' i.e., LST plus any optional arguments. PRED + is applied to successive elements of the list arguments in order. + `some' returns `#t' as soon as one of these applications returns + `#t', and is `#f' if none returns `#t'. All the lists should have + the same length. + + Example: + (some odd? '(1 2 3 4)) + => #t + + (some odd? '(2 4 6 8)) + => #f + + (some > '(2 3) '(1 4)) + => #f + + - Function: every PRED LST . MORE-LSTS + `every' is analogous to `some' except it returns `#t' if every + application of PRED is `#t' and `#f' otherwise. + + Example: + (every even? '(1 2 3 4)) + => #f + + (every even? '(2 4 6 8)) + => #t + + (every > '(2 3) '(1 4)) + => #f + + - Function: notany PRED . LST + `notany' is analogous to `some' but returns `#t' if no application + of PRED returns `#t' or `#f' as soon as any one does. + + - Function: notevery PRED . LST + `notevery' is analogous to `some' but returns `#t' as soon as an + application of PRED returns `#f', and `#f' otherwise. + + Example: + (notevery even? '(1 2 3 4)) + => #t + + (notevery even? '(2 4 6 8)) + => #f + + - Function: find-if PRED LST + `find-if' searches for the first ELEMENT in LST such that `(PRED + ELEMENT)' returns `#t'. If it finds any such ELEMENT in LST, + ELEMENT is returned. Otherwise, `#f' is returned. + + Example: + (find-if number? '(foo 1 bar 2)) + => 1 + + (find-if number? '(foo bar baz bang)) + => #f + + (find-if symbol? '(1 2 foo bar)) + => foo + + - Function: remove ELT LST + `remove' removes all occurrences of ELT from LST using `eqv?' to + test for equality and returns everything that's left. N.B.: other + implementations (Chez, Scheme->C and T, at least) use `equal?' as + the equality test. + + Example: + (remove 1 '(1 2 1 3 1 4 1 5)) + => (2 3 4 5) + + (remove 'foo '(bar baz bang)) + => (bar baz bang) + + - Function: remove-if PRED LST + `remove-if' removes all ELEMENTs from LST where `(PRED ELEMENT)' + is `#t' and returns everything that's left. + + Example: + (remove-if number? '(1 2 3 4)) + => () + + (remove-if even? '(1 2 3 4 5 6 7 8)) + => (1 3 5 7) + + - Function: remove-if-not PRED LST + `remove-if-not' removes all ELEMENTs from LST for which `(PRED + ELEMENT)' is `#f' and returns everything that's left. + + Example: + (remove-if-not number? '(foo bar baz)) + => () + (remove-if-not odd? '(1 2 3 4 5 6 7 8)) + => (1 3 5 7) + + - Function: has-duplicates? LST + returns `#t' if 2 members of LST are `equal?', `#f' otherwise. + Example: + (has-duplicates? '(1 2 3 4)) + => #f + + (has-duplicates? '(2 4 3 4)) + => #t + + +File: slib.info, Node: Lists as sequences, Next: Destructive list operations, Prev: Lists as sets, Up: Common List Functions + +Lists as sequences +------------------ + + - Function: position OBJ LST + `position' returns the 0-based position of OBJ in LST, or `#f' if + OBJ does not occur in LST. + + Example: + (position 'foo '(foo bar baz bang)) + => 0 + (position 'baz '(foo bar baz bang)) + => 2 + (position 'oops '(foo bar baz bang)) + => #f + + - Function: reduce P LST + `reduce' combines all the elements of a sequence using a binary + operation (the combination is left-associative). For example, + using `+', one can add up all the elements. `reduce' allows you to + apply a function which accepts only two arguments to more than 2 + objects. Functional programmers usually refer to this as "foldl". + `collect:reduce' (*Note Collections::) provides a version of + `collect' generalized to collections. + + Example: + (reduce + '(1 2 3 4)) + => 10 + (define (bad-sum . l) (reduce + l)) + (bad-sum 1 2 3 4) + == (reduce + (1 2 3 4)) + == (+ (+ (+ 1 2) 3) 4) + => 10 + (bad-sum) + == (reduce + ()) + => () + (reduce string-append '("hello" "cruel" "world")) + == (string-append (string-append "hello" "cruel") "world") + => "hellocruelworld" + (reduce anything '()) + => () + (reduce anything '(x)) + => x + + What follows is a rather non-standard implementation of `reverse' + in terms of `reduce' and a combinator elsewhere called "C". + + ;;; Contributed by Jussi Piitulainen (jpiitula@ling.helsinki.fi) + + (define commute + (lambda (f) + (lambda (x y) + (f y x)))) + + (define reverse + (lambda (args) + (reduce-init (commute cons) args))) + + - Function: reduce-init P INIT LST + `reduce-init' is the same as reduce, except that it implicitly + inserts INIT at the start of the list. `reduce-init' is preferred + if you want to handle the null list, the one-element, and lists + with two or more elements consistently. It is common to use the + operator's idempotent as the initializer. Functional programmers + usually call this "foldl". + + Example: + (define (sum . l) (reduce-init + 0 l)) + (sum 1 2 3 4) + == (reduce-init + 0 (1 2 3 4)) + == (+ (+ (+ (+ 0 1) 2) 3) 4) + => 10 + (sum) + == (reduce-init + 0 '()) + => 0 + + (reduce-init string-append "@" '("hello" "cruel" "world")) + == + (string-append (string-append (string-append "@" "hello") + "cruel") + "world") + => "@hellocruelworld" + + Given a differentiation of 2 arguments, `diff', the following will + differentiate by any number of variables. + (define (diff* exp . vars) + (reduce-init diff exp vars)) + + Example: + ;;; Real-world example: Insertion sort using reduce-init. + + (define (insert l item) + (if (null? l) + (list item) + (if (< (car l) item) + (cons (car l) (insert (cdr l) item)) + (cons item l)))) + (define (insertion-sort l) (reduce-init insert '() l)) + + (insertion-sort '(3 1 4 1 5) + == (reduce-init insert () (3 1 4 1 5)) + == (insert (insert (insert (insert (insert () 3) 1) 4) 1) 5) + == (insert (insert (insert (insert (3)) 1) 4) 1) 5) + == (insert (insert (insert (1 3) 4) 1) 5) + == (insert (insert (1 3 4) 1) 5) + == (insert (1 1 3 4) 5) + => (1 1 3 4 5) + + - Function: butlast LST N + `butlast' returns all but the last N elements of LST. + + Example: + (butlast '(1 2 3 4) 3) + => (1) + (butlast '(1 2 3 4) 4) + => () + + - Function: nthcdr N LST + `nthcdr' takes N `cdr's of LST and returns the result. Thus + `(nthcdr 3 LST)' == `(cdddr LST)' + + Example: + (nthcdr 2 '(1 2 3 4)) + => (3 4) + (nthcdr 0 '(1 2 3 4)) + => (1 2 3 4) + + - Function: last LST N + `last' returns the last N elements of LST. N must be a + non-negative integer. + + Example: + (last '(foo bar baz bang) 2) + => (baz bang) + (last '(1 2 3) 0) + => 0 + + +File: slib.info, Node: Destructive list operations, Next: Non-List functions, Prev: Lists as sequences, Up: Common List Functions + +Destructive list operations +--------------------------- + + These procedures may mutate the list they operate on, but any such +mutation is undefined. + + - Procedure: nconc ARGS + `nconc' destructively concatenates its arguments. (Compare this + with `append', which copies arguments rather than destroying them.) + Sometimes called `append!' (*Note Rev2 Procedures::). + + Example: You want to find the subsets of a set. Here's the + obvious way: + + (define (subsets set) + (if (null? set) + '(()) + (append (mapcar (lambda (sub) (cons (car set) sub)) + (subsets (cdr set))) + (subsets (cdr set))))) + But that does way more consing than you need. Instead, you could + replace the `append' with `nconc', since you don't have any need + for all the intermediate results. + + Example: + (define x '(a b c)) + (define y '(d e f)) + (nconc x y) + => (a b c d e f) + x + => (a b c d e f) + + `nconc' is the same as `append!' in `sc2.scm'. + + - Procedure: nreverse LST + `nreverse' reverses the order of elements in LST by mutating + `cdr's of the list. Sometimes called `reverse!'. + + Example: + (define foo '(a b c)) + (nreverse foo) + => (c b a) + foo + => (a) + + Some people have been confused about how to use `nreverse', + thinking that it doesn't return a value. It needs to be pointed + out that + (set! lst (nreverse lst)) + + is the proper usage, not + (nreverse lst) + The example should suffice to show why this is the case. + + - Procedure: delete ELT LST + - Procedure: delete-if PRED LST + - Procedure: delete-if-not PRED LST + Destructive versions of `remove' `remove-if', and `remove-if-not'. + + Example: + (define lst '(foo bar baz bang)) + (delete 'foo lst) + => (bar baz bang) + lst + => (foo bar baz bang) + + (define lst '(1 2 3 4 5 6 7 8 9)) + (delete-if odd? lst) + => (2 4 6 8) + lst + => (1 2 4 6 8) + + Some people have been confused about how to use `delete', + `delete-if', and `delete-if', thinking that they dont' return a + value. It needs to be pointed out that + (set! lst (delete el lst)) + + is the proper usage, not + (delete el lst) + The examples should suffice to show why this is the case. + + +File: slib.info, Node: Non-List functions, Prev: Destructive list operations, Up: Common List Functions + +Non-List functions +------------------ + + - Function: and? . ARGS + `and?' checks to see if all its arguments are true. If they are, + `and?' returns `#t', otherwise, `#f'. (In contrast to `and', this + is a function, so all arguments are always evaluated and in an + unspecified order.) + + Example: + (and? 1 2 3) + => #t + (and #f 1 2) + => #f + + - Function: or? . ARGS + `or?' checks to see if any of its arguments are true. If any is + true, `or?' returns `#t', and `#f' otherwise. (To `or' as `and?' + is to `and'.) + + Example: + (or? 1 2 #f) + => #t + (or? #f #f #f) + => #f + + - Function: atom? OBJECT + Returns `#t' if OBJECT is not a pair and `#f' if it is pair. + (Called `atom' in Common LISP.) + (atom? 1) + => #t + (atom? '(1 2)) + => #f + (atom? #(1 2)) ; dubious! + => #t + + - Function: type-of OBJECT + Returns a symbol name for the type of OBJECT. + + - Function: coerce OBJECT RESULT-TYPE + Converts and returns OBJECT of type `char', `number', `string', + `symbol', `list', or `vector' to RESULT-TYPE (which must be one of + these symbols). + + +File: slib.info, Node: Format, Next: Generic-Write, Prev: Common List Functions, Up: Procedures + +Format +====== + + `(require 'format)' + +* Menu: + +* Format Interface:: +* Format Specification:: + + +File: slib.info, Node: Format Interface, Next: Format Specification, Prev: Format, Up: Format + +Format Interface +---------------- + + - Function: format DESTINATION FORMAT-STRING . ARGUMENTS + An almost complete implementation of Common LISP format description + according to the CL reference book `Common LISP' from Guy L. + Steele, Digital Press. Backward compatible to most of the + available Scheme format implementations. + + Returns `#t', `#f' or a string; has side effect of printing + according to FORMAT-STRING. If DESTINATION is `#t', the output is + to the current output port and `#t' is returned. If DESTINATION + is `#f', a formatted string is returned as the result of the call. + NEW: If DESTINATION is a string, DESTINATION is regarded as the + format string; FORMAT-STRING is then the first argument and the + output is returned as a string. If DESTINATION is a number, the + output is to the current error port if available by the + implementation. Otherwise DESTINATION must be an output port and + `#t' is returned. + + FORMAT-STRING must be a string. In case of a formatting error + format returns `#f' and prints a message on the current output or + error port. Characters are output as if the string were output by + the `display' function with the exception of those prefixed by a + tilde (~). For a detailed description of the FORMAT-STRING syntax + please consult a Common LISP format reference manual. For a test + suite to verify this format implementation load `formatst.scm'. + Please send bug reports to `lutzeb@cs.tu-berlin.de'. + + Note: `format' is not reentrant, i.e. only one `format'-call may + be executed at a time. + + + +File: slib.info, Node: Format Specification, Prev: Format Interface, Up: Format + +Format Specification (Format version 3.0) +----------------------------------------- + + Please consult a Common LISP format reference manual for a detailed +description of the format string syntax. For a demonstration of the +implemented directives see `formatst.scm'. + + This implementation supports directive parameters and modifiers (`:' +and `@' characters). Multiple parameters must be separated by a comma +(`,'). Parameters can be numerical parameters (positive or negative), +character parameters (prefixed by a quote character (`''), variable +parameters (`v'), number of rest arguments parameter (`#'), empty and +default parameters. Directive characters are case independent. The +general form of a directive is: + +DIRECTIVE ::= ~{DIRECTIVE-PARAMETER,}[:][@]DIRECTIVE-CHARACTER + +DIRECTIVE-PARAMETER ::= [ [-|+]{0-9}+ | 'CHARACTER | v | # ] + +Implemented CL Format Control Directives +........................................ + + Documentation syntax: Uppercase characters represent the corresponding +control directive characters. Lowercase characters represent control +directive parameter descriptions. + +`~A' + Any (print as `display' does). + `~@A' + left pad. + + `~MINCOL,COLINC,MINPAD,PADCHARA' + full padding. + +`~S' + S-expression (print as `write' does). + `~@S' + left pad. + + `~MINCOL,COLINC,MINPAD,PADCHARS' + full padding. + +`~D' + Decimal. + `~@D' + print number sign always. + + `~:D' + print comma separated. + + `~MINCOL,PADCHAR,COMMACHARD' + padding. + +`~X' + Hexadecimal. + `~@X' + print number sign always. + + `~:X' + print comma separated. + + `~MINCOL,PADCHAR,COMMACHARX' + padding. + +`~O' + Octal. + `~@O' + print number sign always. + + `~:O' + print comma separated. + + `~MINCOL,PADCHAR,COMMACHARO' + padding. + +`~B' + Binary. + `~@B' + print number sign always. + + `~:B' + print comma separated. + + `~MINCOL,PADCHAR,COMMACHARB' + padding. + +`~NR' + Radix N. + `~N,MINCOL,PADCHAR,COMMACHARR' + padding. + +`~@R' + print a number as a Roman numeral. + +`~:R' + print a number as an ordinal English number. + +`~:@R' + print a number as a cardinal English number. + +`~P' + Plural. + `~@P' + prints `y' and `ies'. + + `~:P' + as `~P but jumps 1 argument backward.' + + `~:@P' + as `~@P but jumps 1 argument backward.' + +`~C' + Character. + `~@C' + prints a character as the reader can understand it (i.e. `#\' + prefixing). + + `~:C' + prints a character as emacs does (eg. `^C' for ASCII 03). + +`~F' + Fixed-format floating-point (prints a flonum like MMM.NNN). + `~WIDTH,DIGITS,SCALE,OVERFLOWCHAR,PADCHARF' + `~@F' + If the number is positive a plus sign is printed. + +`~E' + Exponential floating-point (prints a flonum like MMM.NNN`E'EE). + `~WIDTH,DIGITS,EXPONENTDIGITS,SCALE,OVERFLOWCHAR,PADCHAR,EXPONENTCHARE' + `~@E' + If the number is positive a plus sign is printed. + +`~G' + General floating-point (prints a flonum either fixed or + exponential). + `~WIDTH,DIGITS,EXPONENTDIGITS,SCALE,OVERFLOWCHAR,PADCHAR,EXPONENTCHARG' + `~@G' + If the number is positive a plus sign is printed. + +`~$' + Dollars floating-point (prints a flonum in fixed with signs + separated). + `~DIGITS,SCALE,WIDTH,PADCHAR$' + `~@$' + If the number is positive a plus sign is printed. + + `~:@$' + A sign is always printed and appears before the padding. + + `~:$' + The sign appears before the padding. + +`~%' + Newline. + `~N%' + print N newlines. + +`~&' + print newline if not at the beginning of the output line. + `~N&' + prints `~&' and then N-1 newlines. + +`~|' + Page Separator. + `~N|' + print N page separators. + +`~~' + Tilde. + `~N~' + print N tildes. + +`~' + Continuation Line. + `~:' + newline is ignored, white space left. + + `~@' + newline is left, white space ignored. + +`~T' + Tabulation. + `~@T' + relative tabulation. + + `~COLNUM,COLINCT' + full tabulation. + +`~?' + Indirection (expects indirect arguments as a list). + `~@?' + extracts indirect arguments from format arguments. + +`~(STR~)' + Case conversion (converts by `string-downcase'). + `~:(STR~)' + converts by `string-capitalize'. + + `~@(STR~)' + converts by `string-capitalize-first'. + + `~:@(STR~)' + converts by `string-upcase'. + +`~*' + Argument Jumping (jumps 1 argument forward). + `~N*' + jumps N arguments forward. + + `~:*' + jumps 1 argument backward. + + `~N:*' + jumps N arguments backward. + + `~@*' + jumps to the 0th argument. + + `~N@*' + jumps to the Nth argument (beginning from 0) + +`~[STR0~;STR1~;...~;STRN~]' + Conditional Expression (numerical clause conditional). + `~N[' + take argument from N. + + `~@[' + true test conditional. + + `~:[' + if-else-then conditional. + + `~;' + clause separator. + + `~:;' + default clause follows. + +`~{STR~}' + Iteration (args come from the next argument (a list)). + `~N{' + at most N iterations. + + `~:{' + args from next arg (a list of lists). + + `~@{' + args from the rest of arguments. + + `~:@{' + args from the rest args (lists). + +`~^' + Up and out. + `~N^' + aborts if N = 0 + + `~N,M^' + aborts if N = M + + `~N,M,K^' + aborts if N <= M <= K + +Not Implemented CL Format Control Directives +............................................ + +`~:A' + print `#f' as an empty list (see below). + +`~:S' + print `#f' as an empty list (see below). + +`~<~>' + Justification. + +`~:^' + (sorry I don't understand its semantics completely) + +Extended, Replaced and Additional Control Directives +.................................................... + +`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHD' +`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHX' +`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHO' +`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHB' +`~N,MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHR' + COMMAWIDTH is the number of characters between two comma + characters. + +`~I' + print a R4RS complex number as `~F~@Fi' with passed parameters for + `~F'. + +`~Y' + Pretty print formatting of an argument for scheme code lists. + +`~K' + Same as `~?.' + +`~!' + Flushes the output if format DESTINATION is a port. + +`~_' + Print a `#\space' character + `~N_' + print N `#\space' characters. + +`~/' + Print a `#\tab' character + `~N/' + print N `#\tab' characters. + +`~NC' + Takes N as an integer representation for a character. No arguments + are consumed. N is converted to a character by `integer->char'. N + must be a positive decimal number. + +`~:S' + Print out readproof. Prints out internal objects represented as + `#<...>' as strings `"#<...>"' so that the format output can always + be processed by `read'. + +`~:A' + Print out readproof. Prints out internal objects represented as + `#<...>' as strings `"#<...>"' so that the format output can always + be processed by `read'. + +`~Q' + Prints information and a copyright notice on the format + implementation. + `~:Q' + prints format version. + +`~F, ~E, ~G, ~$' + may also print number strings, i.e. passing a number as a string + and format it accordingly. + +Configuration Variables +....................... + + Format has some configuration variables at the beginning of +`format.scm' to suit the systems and users needs. There should be no +modification necessary for the configuration that comes with SLIB. If +modification is desired the variable should be set after the format +code is loaded. Format detects automatically if the running scheme +system implements floating point numbers and complex numbers. + +FORMAT:SYMBOL-CASE-CONV + Symbols are converted by `symbol->string' so the case type of the + printed symbols is implementation dependent. + `format:symbol-case-conv' is a one arg closure which is either + `#f' (no conversion), `string-upcase', `string-downcase' or + `string-capitalize'. (default `#f') + +FORMAT:IOBJ-CASE-CONV + As FORMAT:SYMBOL-CASE-CONV but applies for the representation of + implementation internal objects. (default `#f') + +FORMAT:EXPCH + The character prefixing the exponent value in `~E' printing. + (default `#\E') + +Compatibility With Other Format Implementations +............................................... + +SLIB format 2.x: + See `format.doc'. + +SLIB format 1.4: + Downward compatible except for padding support and `~A', `~S', + `~P', `~X' uppercase printing. SLIB format 1.4 uses C-style + `printf' padding support which is completely replaced by the CL + `format' padding style. + +MIT C-Scheme 7.1: + Downward compatible except for `~', which is not documented + (ignores all characters inside the format string up to a newline + character). (7.1 implements `~a', `~s', ~NEWLINE, `~~', `~%', + numerical and variable parameters and `:/@' modifiers in the CL + sense). + +Elk 1.5/2.0: + Downward compatible except for `~A' and `~S' which print in + uppercase. (Elk implements `~a', `~s', `~~', and `~%' (no + directive parameters or modifiers)). + +Scheme->C 01nov91: + Downward compatible except for an optional destination parameter: + S2C accepts a format call without a destination which returns a + formatted string. This is equivalent to a #f destination in S2C. + (S2C implements `~a', `~s', `~c', `~%', and `~~' (no directive + parameters or modifiers)). + + This implementation of format is solely useful in the SLIB context +because it requires other components provided by SLIB. + + +File: slib.info, Node: Generic-Write, Next: Line I/O, Prev: Format, Up: Procedures + +Generic-Write +============= + + `(require 'generic-write)' + + `generic-write' is a procedure that transforms a Scheme data value +(or Scheme program expression) into its textual representation and +prints it. The interface to the procedure is sufficiently general to +easily implement other useful formatting procedures such as pretty +printing, output to a string and truncated output. + + - Procedure: generic-write OBJ DISPLAY? WIDTH OUTPUT + OBJ + Scheme data value to transform. + + DISPLAY? + Boolean, controls whether characters and strings are quoted. + + WIDTH + Extended boolean, selects format: + #f + single line format + + integer > 0 + pretty-print (value = max nb of chars per line) + + OUTPUT + Procedure of 1 argument of string type, called repeatedly with + successive substrings of the textual representation. This + procedure can return `#f' to stop the transformation. + + The value returned by `generic-write' is undefined. + + Examples: + (write obj) == (generic-write obj #f #f DISPLAY-STRING) + (display obj) == (generic-write obj #t #f DISPLAY-STRING) + + where + DISPLAY-STRING == + (lambda (s) (for-each write-char (string->list s)) #t) + + +File: slib.info, Node: Line I/O, Next: Multi-Processing, Prev: Generic-Write, Up: Procedures + +Line I/O +======== + + `(require 'line-i/o)' + + - Function: read-line + - Function: read-line PORT + Returns a string of the characters up to, but not including a + newline or end of file, updating PORT to point to the character + following the newline. If no characters are available, an end of + file object is returned. PORT may be omitted, in which case it + defaults to the value returned by `current-input-port'. + + - Function: read-line! STRING + - Function: read-line! STRING PORT + Fills STRING with characters up to, but not including a newline or + end of file, updating the port to point to the last character read + or following the newline if it was read. If no characters are + available, an end of file object is returned. If a newline or end + of file was found, the number of characters read is returned. + Otherwise, `#f' is returned. PORT may be omitted, in which case + it defaults to the value returned by `current-input-port'. + + - Function: write-line STRING + - Function: write-line STRING PORT + Writes STRING followed by a newline to the given port and returns + an unspecified value. Port may be omited, in which case it + defaults to the value returned by `current-input-port'. + + +File: slib.info, Node: Multi-Processing, Next: Object-To-String, Prev: Line I/O, Up: Procedures + +Multi-Processing +================ + + `(require 'process)' + + - Procedure: add-process! PROC + Adds proc, which must be a procedure (or continuation) capable of + accepting accepting one argument, to the `process:queue'. The + value returned is unspecified. The argument to PROC should be + ignored. If PROC returns, the process is killed. + + - Procedure: process:schedule! + Saves the current process on `process:queue' and runs the next + process from `process:queue'. The value returned is unspecified. + + - Procedure: kill-process! + Kills the current process and runs the next process from + `process:queue'. If there are no more processes on + `process:queue', `(slib:exit)' is called (*Note System::). + + +File: slib.info, Node: Object-To-String, Next: Pretty-Print, Prev: Multi-Processing, Up: Procedures + +Object-To-String +================ + + `(require 'object->string)' + + - Function: object->string OBJ + Returns the textual representation of OBJ as a string. + + +File: slib.info, Node: Pretty-Print, Next: Sorting, Prev: Object-To-String, Up: Procedures + +Pretty-Print +============ + + `(require 'pretty-print)' + + - Procedure: pretty-print OBJ + - Procedure: pretty-print OBJ PORT + `pretty-print's OBJ on PORT. If PORT is not specified, + `current-output-port' is used. + + Example: + (pretty-print '((1 2 3 4 5) (6 7 8 9 10) (11 12 13 14 15) + (16 17 18 19 20) (21 22 23 24 25))) + -| ((1 2 3 4 5) + -| (6 7 8 9 10) + -| (11 12 13 14 15) + -| (16 17 18 19 20) + -| (21 22 23 24 25)) + + `(require 'pprint-file)' + + - Procedure: pprint-file INFILE + - Procedure: pprint-file INFILE OUTFILE + Pretty-prints all the code in INFILE. If OUTFILE is specified, + the output goes to OUTFILE, otherwise it goes to + `(current-output-port)'. + + - Function: pprint-filter-file INFILE PROC OUTFILE + - Function: pprint-filter-file INFILE PROC + INFILE is a port or a string naming an existing file. Scheme + source code expressions and definitions are read from the port (or + file) and PROC is applied to them sequentially. + + OUTFILE is a port or a string. If no OUTFILE is specified then + `current-output-port' is assumed. These expanded expressions are + then `pretty-print'ed to this port. + + Whitepsace and comments (introduced by `;') which are not part of + scheme expressions are reproduced in the output. This procedure + does not affect the values returned by `current-input-port' and + `current-output-port'. + + `pprint-filter-file' can be used to pre-compile macro-expansion and +thus can reduce loading time. The following will write into +`exp-code.scm' the result of expanding all defmacros in `code.scm'. + (require 'pprint-file) + (require 'defmacroexpand) + (defmacro:load "my-macros.scm") + (pprint-filter-file "code.scm" defmacro:expand* "exp-code.scm") + diff --git a/slib.info-6 b/slib.info-6 new file mode 100644 index 0000000..05d8377 --- /dev/null +++ b/slib.info-6 @@ -0,0 +1,1410 @@ +This is Info file slib.info, produced by Makeinfo-1.64 from the input +file slib.texi. + + This file documents SLIB, the portable Scheme library. + + Copyright (C) 1993 Todd R. Eigenschink Copyright (C) 1993, 1994, 1995 +Aubrey Jaffer + + Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + + Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + + Permission is granted to copy and distribute translations of this +manual into another language, under the above conditions for modified +versions, except that this permission notice may be stated in a +translation approved by the author. + + +File: slib.info, Node: Sorting, Next: Topological Sort, Prev: Pretty-Print, Up: Procedures + +Sorting +======= + + `(require 'sort)' + + Many Scheme systems provide some kind of sorting functions. They do +not, however, always provide the *same* sorting functions, and those +that I have had the opportunity to test provided inefficient ones (a +common blunder is to use quicksort which does not perform well). + + Because `sort' and `sort!' are not in the standard, there is very +little agreement about what these functions look like. For example, +Dybvig says that Chez Scheme provides + (merge predicate list1 list2) + (merge! predicate list1 list2) + (sort predicate list) + (sort! predicate list) + +while MIT Scheme 7.1, following Common LISP, offers unstable + (sort list predicate) + +TI PC Scheme offers + (sort! list/vector predicate?) + +and Elk offers + (sort list/vector predicate?) + (sort! list/vector predicate?) + + Here is a comprehensive catalogue of the variations I have found. + + 1. Both `sort' and `sort!' may be provided. + + 2. `sort' may be provided without `sort!'. + + 3. `sort!' may be provided without `sort'. + + 4. Neither may be provided. + + 5. The sequence argument may be either a list or a vector. + + 6. The sequence argument may only be a list. + + 7. The sequence argument may only be a vector. + + 8. The comparison function may be expected to behave like `<'. + + 9. The comparison function may be expected to behave like `<='. + + 10. The interface may be `(sort predicate? sequence)'. + + 11. The interface may be `(sort sequence predicate?)'. + + 12. The interface may be `(sort sequence &optional (predicate? <))'. + + 13. The sort may be stable. + + 14. The sort may be unstable. + + All of this variation really does not help anybody. A nice simple +merge sort is both stable and fast (quite a lot faster than *quick* +sort). + + I am providing this source code with no restrictions at all on its use +(but please retain D.H.D.Warren's credit for the original idea). You +may have to rename some of these functions in order to use them in a +system which already provides incompatible or inferior sorts. For each +of the functions, only the top-level define needs to be edited to do +that. + + I could have given these functions names which would not clash with +any Scheme that I know of, but I would like to encourage implementors to +converge on a single interface, and this may serve as a hint. The +argument order for all functions has been chosen to be as close to +Common LISP as made sense, in order to avoid NIH-itis. + + Each of the five functions has a required *last* parameter which is a +comparison function. A comparison function `f' is a function of 2 +arguments which acts like `<'. For example, + + (not (f x x)) + (and (f x y) (f y z)) == (f x z) + + The standard functions `<', `>', `char?', `char-ci?', `string?', `string-ci?' +are suitable for use as comparison functions. Think of `(less? x y)' +as saying when `x' must *not* precede `y'. + + - Function: sorted? SEQUENCE LESS? + Returns `#t' when the sequence argument is in non-decreasing order + according to LESS? (that is, there is no adjacent pair `... x y + ...' for which `(less? y x)'). + + Returns `#f' when the sequence contains at least one out-of-order + pair. It is an error if the sequence is neither a list nor a + vector. + + - Function: merge LIST1 LIST2 LESS? + This merges two lists, producing a completely new list as result. + I gave serious consideration to producing a Common-LISP-compatible + version. However, Common LISP's `sort' is our `sort!' (well, in + fact Common LISP's `stable-sort' is our `sort!', merge sort is + *fast* as well as stable!) so adapting CL code to Scheme takes a + bit of work anyway. I did, however, appeal to CL to determine the + *order* of the arguments. + + - Procedure: merge! LIST1 LIST2 LESS? + Merges two lists, re-using the pairs of LIST1 and LIST2 to build + the result. If the code is compiled, and LESS? constructs no new + pairs, no pairs at all will be allocated. The first pair of the + result will be either the first pair of LIST1 or the first pair of + LIST2, but you can't predict which. + + The code of `merge' and `merge!' could have been quite a bit + simpler, but they have been coded to reduce the amount of work + done per iteration. (For example, we only have one `null?' test + per iteration.) + + - Function: sort SEQUENCE LESS? + Accepts either a list or a vector, and returns a new sequence + which is sorted. The new sequence is the same type as the input. + Always `(sorted? (sort sequence less?) less?)'. The original + sequence is not altered in any way. The new sequence shares its + *elements* with the old one; no elements are copied. + + - Procedure: sort! SEQUENCE LESS? + Returns its sorted result in the original boxes. If the original + sequence is a list, no new storage is allocated at all. If the + original sequence is a vector, the sorted elements are put back in + the same vector. + + Some people have been confused about how to use `sort!', thinking + that it doesn't return a value. It needs to be pointed out that + (set! slist (sort! slist <)) + + is the proper usage, not + (sort! slist <) + + Note that these functions do *not* accept a CL-style `:key' argument. +A simple device for obtaining the same expressiveness is to define + (define (keyed less? key) + (lambda (x y) (less? (key x) (key y)))) + +and then, when you would have written + (sort a-sequence #'my-less :key #'my-key) + +in Common LISP, just write + (sort! a-sequence (keyed my-less? my-key)) + +in Scheme. + + +File: slib.info, Node: Topological Sort, Next: Standard Formatted I/O, Prev: Sorting, Up: Procedures + +Topological Sort +================ + + `(require 'topological-sort)' or `(require 'tsort)' + +The algorithm is inspired by Cormen, Leiserson and Rivest (1990) +`Introduction to Algorithms', chapter 23. + + - Function: tsort DAG PRED + - Function: topological-sort DAG PRED + where + DAG + is a list of sublists. The car of each sublist is a vertex. + The cdr is the adjacency list of that vertex, i.e. a list of + all vertices to which there exists an edge from the car + vertex. + + PRED + is one of `eq?', `eqv?', `equal?', `=', `char=?', + `char-ci=?', `string=?', or `string-ci=?'. + + Sort the directed acyclic graph DAG so that for every edge from + vertex U to V, U will come before V in the resulting list of + vertices. + + Time complexity: O (|V| + |E|) + + Example (from Cormen): + Prof. Bumstead topologically sorts his clothing when getting + dressed. The first argument to `tsort' describes which + garments he needs to put on before others. (For example, + Prof Bumstead needs to put on his shirt before he puts on his + tie or his belt.) `tsort' gives the correct order of + dressing: + + (require 'tsort) + (tsort '((shirt tie belt) + (tie jacket) + (belt jacket) + (watch) + (pants shoes belt) + (undershorts pants shoes) + (socks shoes)) + eq?) + => + (socks undershorts pants shoes watch shirt belt tie jacket) + + +File: slib.info, Node: Standard Formatted I/O, Next: String-Case, Prev: Topological Sort, Up: Procedures + +Standard Formatted I/O +====================== + +* Menu: + +* Standard Formatted Output:: +* Standard Formatted Input:: + +stdio +----- + + `(require 'stdio)' + + `require's `printf' and `scanf' and additionally defines the symbols: + + - Variable: stdin + Defined to be `(current-input-port)'. + + - Variable: stdout + Defined to be `(current-output-port)'. + + - Variable: stderr + Defined to be `(current-error-port)'. + + +File: slib.info, Node: Standard Formatted Output, Next: Standard Formatted Input, Prev: Standard Formatted I/O, Up: Standard Formatted I/O + +Standard Formatted Output +------------------------- + + `(require 'printf)' + + - Procedure: printf FORMAT ARG1 ... + - Procedure: fprintf PORT FORMAT ARG1 ... + - Procedure: sprintf STR FORMAT ARG1 ... + Each function converts, formats, and outputs its ARG1 ... + arguments according to the control string FORMAT argument and + returns the number of characters output. + + `printf' sends its output to the port `(current-output-port)'. + `fprintf' sends its output to the port PORT. `sprintf' + `string-set!'s locations of the non-constant string argument STR + to the output characters. + + *Note:* sprintf should be changed to a macro so a `substring' + expression could be used for the STR argument. + + The string FORMAT contains plain characters which are copied to + the output stream, and conversion specifications, each of which + results in fetching zero or more of the arguments ARG1 .... The + results are undefined if there are an insufficient number of + arguments for the format. If FORMAT is exhausted while some of the + ARG1 ... arguments remain unused, the excess ARG1 ... arguments + are ignored. + + The conversion specifications in a format string have the form: + + % [ FLAGS ] [ WIDTH ] [ . PRECISION ] [ TYPE ] CONVERSION + + An output conversion specifications consist of an initial `%' + character followed in sequence by: + + * Zero or more "flag characters" that modify the normal + behavior of the conversion specification. + + `-' + Left-justify the result in the field. Normally the + result is right-justified. + + `+' + For the signed `%d' and `%i' conversions and all inexact + conversions, prefix a plus sign if the value is positive. + + ` ' + For the signed `%d' and `%i' conversions, if the result + doesn't start with a plus or minus sign, prefix it with + a space character instead. Since the `+' flag ensures + that the result includes a sign, this flag is ignored if + both are specified. + + `#' + For inexact conversions, `#' specifies that the result + should always include a decimal point, even if no digits + follow it. For the `%g' and `%G' conversions, this also + forces trailing zeros after the decimal point to be + printed where they would otherwise be elided. + + For the `%o' conversion, force the leading digit to be + `0', as if by increasing the precision. For `%x' or + `%X', prefix a leading `0x' or `0X' (respectively) to + the result. This doesn't do anything useful for the + `%d', `%i', or `%u' conversions. Using this flag + produces output which can be parsed by the `scanf' + functions with the `%i' conversion (*note Standard + Formatted Input::.). + + `0' + Pad the field with zeros instead of spaces. The zeros + are placed after any indication of sign or base. This + flag is ignored if the `-' flag is also specified, or if + a precision is specified for an exact converson. + + * An optional decimal integer specifying the "minimum field + width". If the normal conversion produces fewer characters + than this, the field is padded (with spaces or zeros per the + `0' flag) to the specified width. This is a *minimum* width; + if the normal conversion produces more characters than this, + the field is *not* truncated. + + Alternatively, if the field width is `*', the next argument + in the argument list (before the actual value to be printed) + is used as the field width. The width value must be an + integer. If the value is negative it is as though the `-' + flag is set (see above) and the absolute value is used as the + field width. + + * An optional "precision" to specify the number of digits to be + written for numeric conversions and the maximum field width + for string conversions. The precision is specified by a + period (`.') followed optionally by a decimal integer (which + defaults to zero if omitted). + + Alternatively, if the precision is `.*', the next argument in + the argument list (before the actual value to be printed) is + used as the precision. The value must be an integer, and is + ignored if negative. If you specify `*' for both the field + width and precision, the field width argument precedes the + precision argument. The `.*' precision is an enhancement. C + library versions may not accept this syntax. + + For the `%f', `%e', and `%E' conversions, the precision + specifies how many digits follow the decimal-point character. + The default precision is `6'. If the precision is + explicitly `0', the decimal point character is suppressed. + + For the `%g' and `%G' conversions, the precision specifies how + many significant digits to print. Significant digits are the + first digit before the decimal point, and all the digits + after it. If the precision is `0' or not specified for `%g' + or `%G', it is treated like a value of `1'. If the value + being printed cannot be expressed accurately in the specified + number of digits, the value is rounded to the nearest number + that fits. + + For exact conversions, if a precision is supplied it + specifies the minimum number of digits to appear; leading + zeros are produced if necessary. If a precision is not + supplied, the number is printed with as many digits as + necessary. Converting an exact `0' with an explicit + precision of zero produces no characters. + + * An optional one of `l', `h' or `L', which is ignored for + numeric conversions. It is an error to specify these + modifiers for non-numeric conversions. + + * A character that specifies the conversion to be applied. + +Exact Conversions +................. + + `d', `i' + Print an integer as a signed decimal number. `%d' and `%i' + are synonymous for output, but are different when used with + `scanf' for input (*note Standard Formatted Input::.). + + `o' + Print an integer as an unsigned octal number. + + `u' + Print an integer as an unsigned decimal number. + + `x', `X' + Print an integer as an unsigned hexadecimal number. `%x' + prints using the digits `0123456789abcdef'. `%X' prints + using the digits `0123456789ABCDEF'. + +Inexact Conversions +................... + + *Note:* Inexact conversions are not supported yet. + + `f' + Print a floating-point number in fixed-point notation. + + `e', `E' + Print a floating-point number in exponential notation. `%e' + prints `e' between mantissa and exponont. `%E' prints `E' + between mantissa and exponont. + + `g', `G' + Print a floating-point number in either normal or exponential + notation, whichever is more appropriate for its magnitude. + `%g' prints `e' between mantissa and exponont. `%G' prints + `E' between mantissa and exponont. + +Other Conversions +................. + + `c' + Print a single character. The `-' flag is the only one which + can be specified. It is an error to specify a precision. + + `s' + Print a string. The `-' flag is the only one which can be + specified. A precision specifies the maximum number of + characters to output; otherwise all characters in the string + are output. + + `a', `A' + Print a scheme expression. The `-' flag left-justifies the + output. The `#' flag specifies that strings and characters + should be quoted as by `write' (which can be read using + `read'); otherwise, output is as `display' prints. A + precision specifies the maximum number of characters to + output; otherwise as many characters as needed are output. + + *Note:* `%a' and `%A' are SLIB extensions. + + `%' + Print a literal `%' character. No argument is consumed. It + is an error to specifiy flags, field width, precision, or + type modifiers with `%%'. + + +File: slib.info, Node: Standard Formatted Input, Prev: Standard Formatted Output, Up: Standard Formatted I/O + +Standard Formatted Input +------------------------ + + `(require 'scanf)' + + - Function: scanf-read-list FORMAT + - Function: scanf-read-list FORMAT PORT + - Function: scanf-read-list FORMAT STRING + + - Macro: scanf FORMAT ARG1 ... + - Macro: fscanf PORT FORMAT ARG1 ... + - Macro: sscanf STR FORMAT ARG1 ... + Each function reads characters, interpreting them according to the + control string FORMAT argument. + + `scanf-read-list' returns a list of the items specified as far as + the input matches FORMAT. `scanf', `fscanf', and `sscanf' return + the number of items successfully matched and stored. `scanf', + `fscanf', and `sscanf' also set the location corresponding to ARG1 + ... using the methods: + + symbol + `set!' + + car expression + `set-car!' + + cdr expression + `set-cdr!' + + vector-ref expression + `vector-set!' + + substring expression + `substring-move-left!' + + The argument to a `substring' expression in ARG1 ... must be a + non-constant string. Characters will be stored starting at the + position specified by the second argument to `substring'. The + number of characters stored will be limited by either the position + specified by the third argument to `substring' or the length of the + matched string, whichever is less. + + The control string, FORMAT, contains conversion specifications and + other characters used to direct interpretation of input sequences. + The control string contains: + + * White-space characters (blanks, tabs, newlines, or formfeeds) + that cause input to be read (and discarded) up to the next + non-white-space character. + + * An ordinary character (not `%') that must match the next + character of the input stream. + + * Conversion specifications, consisting of the character `%', an + optional assignment suppressing character `*', an optional + numerical maximum-field width, an optional `l', `h' or `L' + which is ignored, and a conversion code. + + Unless the specification contains the `n' conversion character + (described below), a conversion specification directs the + conversion of the next input field. The result of a conversion + specification is returned in the position of the corresponding + argument points, unless `*' indicates assignment suppression. + Assignment suppression provides a way to describe an input field + to be skipped. An input field is defined as a string of + characters; it extends to the next inappropriate character or + until the field width, if specified, is exhausted. + + *Note:* This specification of format strings differs from the + `ANSI C' and `POSIX' specifications. In SLIB, white space + before an input field is not skipped unless white space + appears before the conversion specification in the format + string. In order to write format strings which work + identically with `ANSI C' and SLIB, prepend whitespace to all + conversion specifications except `[' and `c'. + + The conversion code indicates the interpretation of the input + field; For a suppressed field, no value is returned. The + following conversion codes are legal: + + `%' + A single % is expected in the input at this point; no value + is returned. + + `d', `D' + A decimal integer is expected. + + `u', `U' + An unsigned decimal integer is expected. + + `o', `O' + An octal integer is expected. + + `x', `X' + A hexadecimal integer is expected. + + `i' + An integer is expected. Returns the value of the next input + item, interpreted according to C conventions; a leading `0' + implies octal, a leading `0x' implies hexadecimal; otherwise, + decimal is assumed. + + `n' + Returns the total number of bytes (including white space) + read by `scanf'. No input is consumed by `%n'. + + `f', `F', `e', `E', `g', `G' + A floating-point number is expected. The input format for + floating-point numbers is an optionally signed string of + digits, possibly containing a radix character `.', followed + by an optional exponent field consisting of an `E' or an `e', + followed by an optional `+', `-', or space, followed by an + integer. + + `c', `C' + WIDTH characters are expected. The normal + skip-over-white-space is suppressed in this case; to read the + next non-space character, use `%1s'. If a field width is + given, a string is returned; up to the indicated number of + characters is read. + + `s', `S' + A character string is expected The input field is terminated + by a white-space character. `scanf' cannot read a null + string. + + `[' + Indicates string data and the normal + skip-over-leading-white-space is suppressed. The left + bracket is followed by a set of characters, called the + scanset, and a right bracket; the input field is the maximal + sequence of input characters consisting entirely of + characters in the scanset. `^', when it appears as the first + character in the scanset, serves as a complement operator and + redefines the scanset as the set of all characters not + contained in the remainder of the scanset string. + Construction of the scanset follows certain conventions. A + range of characters may be represented by the construct + first-last, enabling `[0123456789]' to be expressed `[0-9]'. + Using this convention, first must be lexically less than or + equal to last; otherwise, the dash stands for itself. The + dash also stands for itself when it is the first or the last + character in the scanset. To include the right square + bracket as an element of the scanset, it must appear as the + first character (possibly preceded by a `^') of the scanset, + in which case it will not be interpreted syntactically as the + closing bracket. At least one character must match for this + conversion to succeed. + + The `scanf' functions terminate their conversions at end-of-file, + at the end of the control string, or when an input character + conflicts with the control string. In the latter case, the + offending character is left unread in the input stream. + + +File: slib.info, Node: String-Case, Next: String Ports, Prev: Standard Formatted I/O, Up: Procedures + +String-Case +=========== + + `(require 'string-case)' + + - Procedure: string-upcase STR + - Procedure: string-downcase STR + - Procedure: string-capitalize STR + The obvious string conversion routines. These are non-destructive. + + - Function: string-upcase! STR + - Function: string-downcase! STR + - Function: string-captialize! STR + The destructive versions of the functions above. + + +File: slib.info, Node: String Ports, Next: String Search, Prev: String-Case, Up: Procedures + +String Ports +============ + + `(require 'string-port)' + + - Procedure: call-with-output-string PROC + PROC must be a procedure of one argument. This procedure calls + PROC with one argument: a (newly created) output port. When the + function returns, the string composed of the characters written + into the port is returned. + + - Procedure: call-with-input-string STRING PROC + PROC must be a procedure of one argument. This procedure calls + PROC with one argument: an (newly created) input port from which + STRING's contents may be read. When PROC returns, the port is + closed and the value yielded by the procedure PROC is returned. + + +File: slib.info, Node: String Search, Next: Tektronix Graphics Support, Prev: String Ports, Up: Procedures + +String Search +============= + + `(require 'string-search)' + + - Procedure: string-index STRING CHAR + Returns the index of the first occurence of CHAR within STRING, or + `#f' if the STRING does not contain a character CHAR. + + - procedure: substring? PATTERN STRING + Searches STRING to see if some substring of STRING is equal to + PATTERN. `substring?' returns the index of the first character of + the first substring of STRING that is equal to PATTERN; or `#f' if + STRING does not contain PATTERN. + + (substring? "rat" "pirate") => 2 + (substring? "rat" "outrage") => #f + (substring? "" any-string) => 0 + + - Procedure: find-string-from-port? STR IN-PORT MAX-NO-CHARS + - Procedure: find-string-from-port? STR IN-PORT + Looks for a string STR within the first MAX-NO-CHARS chars of the + input port IN-PORT. MAX-NO-CHARS may be omitted: in that case, + the search span is limited by the end of the input stream. When + the STR is found, the function returns the number of characters it + has read from the port, and the port is set to read the first char + after that (that is, after the STR) The function returns `#f' when + the STR isn't found. + + `find-string-from-port?' reads the port *strictly* sequentially, + and does not perform any buffering. So `find-string-from-port?' + can be used even if the IN-PORT is open to a pipe or other + communication channel. + + +File: slib.info, Node: Tektronix Graphics Support, Next: Tree Operations, Prev: String Search, Up: Procedures + +Tektronix Graphics Support +========================== + + *Note:* The Tektronix graphics support files need more work, and are +not complete. + +Tektronix 4000 Series Graphics +------------------------------ + + The Tektronix 4000 series graphics protocol gives the user a 1024 by +1024 square drawing area. The origin is in the lower left corner of the +screen. Increasing y is up and increasing x is to the right. + + The graphics control codes are sent over the current-output-port and +can be mixed with regular text and ANSI or other terminal control +sequences. + + - Procedure: tek40:init + + - Procedure: tek40:graphics + + - Procedure: tek40:text + + - Procedure: tek40:linetype LINETYPE + + - Procedure: tek40:move X Y + + - Procedure: tek40:draw X Y + + - Procedure: tek40:put-text X Y STR + + - Procedure: tek40:reset + +Tektronix 4100 Series Graphics +------------------------------ + + The graphics control codes are sent over the current-output-port and +can be mixed with regular text and ANSI or other terminal control +sequences. + + - Procedure: tek41:init + + - Procedure: tek41:reset + + - Procedure: tek41:graphics + + - Procedure: tek41:move X Y + + - Procedure: tek41:draw X Y + + - Procedure: tek41:point X Y NUMBER + + - Procedure: tek41:encode-x-y X Y + + - Procedure: tek41:encode-int NUMBER + + +File: slib.info, Node: Tree Operations, Prev: Tektronix Graphics Support, Up: Procedures + +Tree operations +=============== + + `(require 'tree)' + + These are operations that treat lists a representations of trees. + + - Function: subst NEW OLD TREE + - Function: substq NEW OLD TREE + - Function: substv NEW OLD TREE + `subst' makes a copy of TREE, substituting NEW for every subtree + or leaf of TREE which is `equal?' to OLD and returns a modified + tree. The original TREE is unchanged, but may share parts with + the result. + + `substq' and `substv' are similar, but test against OLD using + `eq?' and `eqv?' respectively. + + Examples: + (substq 'tempest 'hurricane '(shakespeare wrote (the hurricane))) + => (shakespeare wrote (the tempest)) + (substq 'foo '() '(shakespeare wrote (twelfth night))) + => (shakespeare wrote (twelfth night . foo) . foo) + (subst '(a . cons) '(old . pair) + '((old . spice) ((old . shoes) old . pair) (old . pair))) + => ((old . spice) ((old . shoes) a . cons) (a . cons)) + + - Function: copy-tree TREE + Makes a copy of the nested list structure TREE using new pairs and + returns it. All levels are copied, so that none of the pairs in + the tree are `eq?' to the original ones - only the leaves are. + + Example: + (define bar '(bar)) + (copy-tree (list bar 'foo)) + => ((bar) foo) + (eq? bar (car (copy-tree (list bar 'foo)))) + => #f + + +File: slib.info, Node: Standards Support, Next: Session Support, Prev: Procedures, Up: Top + +Standards Support +***************** + +* Menu: + +* With-File:: 'with-file +* Transcripts:: 'transcript +* Rev2 Procedures:: 'rev2-procedures +* Rev4 Optional Procedures:: 'rev4-optional-procedures +* Multi-argument / and -:: 'multiarg/and- +* Multi-argument Apply:: 'multiarg-apply +* Rationalize:: 'rationalize +* Promises:: 'promise +* Dynamic-Wind:: 'dynamic-wind +* Values:: 'values +* Time:: 'time +* CLTime:: 'common-lisp-time + + +File: slib.info, Node: With-File, Next: Transcripts, Prev: Standards Support, Up: Standards Support + +With-File +========= + + `(require 'with-file)' + + - Function: with-input-from-file FILE THUNK + - Function: with-output-to-file FILE THUNK + Description found in R4RS. + + +File: slib.info, Node: Transcripts, Next: Rev2 Procedures, Prev: With-File, Up: Standards Support + +Transcripts +=========== + + `(require 'transcript)' + + - Function: transcript-on FILENAME + - Function: transcript-off FILENAME + Redefines `read-char', `read', `write-char', `write', `display', + and `newline'. + + +File: slib.info, Node: Rev2 Procedures, Next: Rev4 Optional Procedures, Prev: Transcripts, Up: Standards Support + +Rev2 Procedures +=============== + + `(require 'rev2-procedures)' + + The procedures below were specified in the `Revised^2 Report on +Scheme'. *N.B.*: The symbols `1+' and `-1+' are not `R4RS' syntax. +Scheme->C, for instance, barfs on this module. + + - Procedure: substring-move-left! STRING1 START1 END1 STRING2 START2 + - Procedure: substring-move-right! STRING1 START1 END1 STRING2 START2 + STRING1 and STRING2 must be a strings, and START1, START2 and END1 + must be exact integers satisfying + + 0 <= START1 <= END1 <= (string-length STRING1) + 0 <= START2 <= END1 - START1 + START2 <= (string-length STRING2) + + `substring-move-left!' and `substring-move-right!' store + characters of STRING1 beginning with index START1 (inclusive) and + ending with index END1 (exclusive) into STRING2 beginning with + index START2 (inclusive). + + `substring-move-left!' stores characters in time order of + increasing indices. `substring-move-right!' stores characters in + time order of increasing indeces. + + - Procedure: substring-fill! STRING START END CHAR + Fills the elements START-END of STRING with the character CHAR. + + - Function: string-null? STR + == `(= 0 (string-length STR))' + + - Procedure: append! . PAIRS + Destructively appends its arguments. Equivalent to `nconc'. + + - Function: 1+ N + Adds 1 to N. + + - Function: -1+ N + Subtracts 1 from N. + + - Function: ? + - Function: >=? + These are equivalent to the procedures of the same name but + without the trailing `?'. + + +File: slib.info, Node: Rev4 Optional Procedures, Next: Multi-argument / and -, Prev: Rev2 Procedures, Up: Standards Support + +Rev4 Optional Procedures +======================== + + `(require 'rev4-optional-procedures)' + + For the specification of these optional procedures, *Note Standard +procedures: (r4rs)Standard procedures. + + - Function: list-tail L P + + - Function: string->list S + + - Function: list->string L + + - Function: string-copy + + - Procedure: string-fill! S OBJ + + - Function: list->vector L + + - Function: vector->list S + + - Procedure: vector-fill! S OBJ + + +File: slib.info, Node: Multi-argument / and -, Next: Multi-argument Apply, Prev: Rev4 Optional Procedures, Up: Standards Support + +Multi-argument / and - +====================== + + `(require 'mutliarg/and-)' + + For the specification of these optional forms, *Note Numerical +operations: (r4rs)Numerical operations. The `two-arg:'* forms are only +defined if the implementation does not support the many-argument forms. + + - Function: two-arg:/ N1 N2 + The original two-argument version of `/'. + + - Function: / DIVIDENT . DIVISORS + + - Function: two-arg:- N1 N2 + The original two-argument version of `-'. + + - Function: - MINUEND . SUBTRAHENDS + + +File: slib.info, Node: Multi-argument Apply, Next: Rationalize, Prev: Multi-argument / and -, Up: Standards Support + +Multi-argument Apply +==================== + + `(require 'multiarg-apply)' + +For the specification of this optional form, *Note Control features: +(r4rs)Control features. + + - Function: two-arg:apply PROC L + The implementation's native `apply'. Only defined for + implementations which don't support the many-argument version. + + - Function: apply PROC . ARGS + + +File: slib.info, Node: Rationalize, Next: Promises, Prev: Multi-argument Apply, Up: Standards Support + +Rationalize +=========== + + `(require 'rationalize)' + + The procedure rationalize is interesting because most programming +languages do not provide anything analogous to it. For simplicity, we +present an algorithm which computes the correct result for exact +arguments (provided the implementation supports exact rational numbers +of unlimited precision), and produces a reasonable answer for inexact +arguments when inexact arithmetic is implemented using floating-point. +We thank Alan Bawden for contributing this algorithm. + + - Function: rationalize X E + + +File: slib.info, Node: Promises, Next: Dynamic-Wind, Prev: Rationalize, Up: Standards Support + +Promises +======== + + `(require 'promise)' + + - Function: make-promise PROC + + Change occurrences of `(delay EXPRESSION)' to `(make-promise (lambda +() EXPRESSION))' and `(define force promise:force)' to implement +promises if your implementation doesn't support them (*note Control +features: (r4rs)Control features.). + + +File: slib.info, Node: Dynamic-Wind, Next: Values, Prev: Promises, Up: Standards Support + +Dynamic-Wind +============ + + `(require 'dynamic-wind)' + + This facility is a generalization of Common LISP `unwind-protect', +designed to take into account the fact that continuations produced by +`call-with-current-continuation' may be reentered. + + - Procedure: dynamic-wind THUNK1 THUNK2 THUNK3 + The arguments THUNK1, THUNK2, and THUNK3 must all be procedures of + no arguments (thunks). + + `dynamic-wind' calls THUNK1, THUNK2, and then THUNK3. The value + returned by THUNK2 is returned as the result of `dynamic-wind'. + THUNK3 is also called just before control leaves the dynamic + context of THUNK2 by calling a continuation created outside that + context. Furthermore, THUNK1 is called before reentering the + dynamic context of THUNK2 by calling a continuation created inside + that context. (Control is inside the context of THUNK2 if THUNK2 + is on the current return stack). + + *Warning:* There is no provision for dealing with errors or + interrupts. If an error or interrupt occurs while using + `dynamic-wind', the dynamic environment will be that in effect at + the time of the error or interrupt. + + +File: slib.info, Node: Values, Next: Time, Prev: Dynamic-Wind, Up: Standards Support + +Values +====== + + `(require 'values)' + + - Function: values OBJ ... + `values' takes any number of arguments, and passes (returns) them + to its continuation. + + - Function: call-with-values THUNK PROC + THUNK must be a procedure of no arguments, and PROC must be a + procedure. `call-with-values' calls THUNK with a continuation + that, when passed some values, calls PROC with those values as + arguments. + + Except for continuations created by the `call-with-values' + procedure, all continuations take exactly one value, as now; the + effect of passing no value or more than one value to continuations + that were not created by the `call-with-values' procedure is + unspecified. + + +File: slib.info, Node: Time, Next: CLTime, Prev: Values, Up: Standards Support + +Time +==== + + The procedures `current-time', `difftime', and `offset-time' are +supported by all implementations (SLIB provides them if feature +`('current-time)' is missing. `current-time' returns a "calendar time" +(caltime) which can be a number or other type. + + - Function: current-time + Returns the time since 00:00:00 GMT, January 1, 1970, measured in + seconds. Note that the reference time is different from the + reference time for `get-universal-time' in *Note CLTime::. On + implementations which cannot support actual times, `current-time' + will increment a counter and return its value when called. + + - Function: difftime CALTIME1 CALTIME0 + Returns the difference (number of seconds) between twe calendar + times: CALTIME1 - CALTIME0. CALTIME0 can also be a number. + + - Function: offset-time CALTIME OFFSET + Returns the calendar time of CALTIME offset by OFFSET number of + seconds `(+ caltime offset)'. + + (require 'posix-time) + + These procedures are intended to be compatible with Posix time +conversion functions. + + - Variable: *timezone* + contains the difference, in seconds, between UTC and local + standard time (for example, in the U.S. Eastern time zone (EST), + timezone is 5*60*60). `*timezone*' is initialized by `tzset'. + + - Function: tzset + initializes the *TIMEZONE* variable from the TZ environment + variable. This function is automatically called by the other time + conversion functions that depend on the time zone. + + - Function: gmtime CALTIME + converts the calendar time CALTIME to a vector of integers + representing the time expressed as Coordinated Universal Time + (UTC). + + - Function: localtime CALTIME + converts the calendar time CALTIME to a vector of integers + expressed relative to the user's time zone. `localtime' sets the + variable *TIMEZONE* with the difference between Coordinated + Universal Time (UTC) and local standard time in seconds by calling + `tzset'. The elements of the returned vector are as follows: + + 0. seconds (0 - 61) + + 1. minutes (0 - 59) + + 2. hours since midnight + + 3. day of month + + 4. month (0 - 11). Note difference from + `decode-universal-time'. + + 5. year (A.D.) + + 6. day of week (0 - 6) + + 7. day of year (0 - 365) + + 8. 1 for daylight savings, 0 for regular time + + - Function: mktime UNIVTIME + Converts a vector of integers in Coordinated Universal Time (UTC) + format to calendar time (caltime) format. + + - Function: asctime UNIVTIME + Converts the vector of integers CALTIME in Coordinated Universal + Time (UTC) format into a string of the form `"Wed Jun 30 21:49:08 + 1993"'. + + - Function: ctime CALTIME + Equivalent to `(time:asctime (time:localtime CALTIME))'. + + +File: slib.info, Node: CLTime, Prev: Time, Up: Standards Support + +CLTime +====== + + - Function: get-decoded-time + Equivalent to `(decode-universal-time (get-universal-time))'. + + - Function: get-universal-time + Returns the current time as "Universal Time", number of seconds + since 00:00:00 Jan 1, 1900 GMT. Note that the reference time is + different from `current-time'. + + - Function: decode-universal-time UNIVTIME + Converts UNIVTIME to "Decoded Time" format. Nine values are + returned: + 0. seconds (0 - 61) + + 1. minutes (0 - 59) + + 2. hours since midnight + + 3. day of month + + 4. month (1 - 12). Note difference from `gmtime' and + `localtime'. + + 5. year (A.D.) + + 6. day of week (0 - 6) + + 7. #t for daylight savings, #f otherwise + + 8. hours west of GMT (-24 - +24) + + Notice that the values returned by `decode-universal-time' do not + match the arguments to `encode-universal-time'. + + - Function: encode-universal-time SECOND MINUTE HOUR DATE MONTH YEAR + - Function: encode-universal-time SECOND MINUTE HOUR DATE MONTH YEAR + TIME-ZONE + Converts the arguments in Decoded Time format to Universal Time + format. If TIME-ZONE is not specified, the returned time is + adjusted for daylight saving time. Otherwise, no adjustment is + performed. + + Notice that the values returned by `decode-universal-time' do not + match the arguments to `encode-universal-time'. + + +File: slib.info, Node: Session Support, Next: Optional SLIB Packages, Prev: Standards Support, Up: Top + +Session Support +*************** + +* Menu: + +* Repl:: Macros at top-level +* Quick Print:: Loop-safe Output +* Debug:: To err is human ... +* Breakpoints:: Pause execution +* Trace:: 'trace +* Getopt:: Command Line option parsing +* Command Line:: A command line reader for Scheme shells +* System Interface:: 'system and 'getenv + +Certain features are so simple, system-dependent, or widely subcribed +that they are supported by all implementations as part of the +`*.init' files. + +The features described in the following sections are provided by all +implementations. + +* Require:: Module Management +* Vicinity:: Pathname Management +* Configuration:: Characteristics of Scheme Implementation +* Input/Output:: Things not provided by the Scheme specs. +* Legacy:: +* System:: LOADing, EVALing, ERRORing, and EXITing + + +File: slib.info, Node: Repl, Next: Quick Print, Prev: Session Support, Up: Session Support + +Repl +==== + + `(require 'repl)' + + Here is a read-eval-print-loop which, given an eval, evaluates forms. + + - Procedure: repl:top-level REPL:EVAL + `read's, `repl:eval's and `write's expressions from + `(current-input-port)' to `(current-output-port)' until an + end-of-file is encountered. `load', `slib:eval', `slib:error', + and `repl:quit' dynamically bound during `repl:top-level'. + + - Procedure: repl:quit + Exits from the invocation of `repl:top-level'. + + The `repl:' procedures establish, as much as is possible to do +portably, a top level environment supporting macros. `repl:top-level' +uses `dynamic-wind' to catch error conditions and interrupts. If your +implementation supports this you are all set. + + Otherwise, if there is some way your implementation can catch error +conditions and interrupts, then have them call `slib:error'. It will +display its arguments and reenter `repl:top-level'. `slib:error' +dynamically bound by `repl:top-level'. + + To have your top level loop always use macros, add any interrupt +catching lines and the following lines to your Scheme init file: + (require 'macro) + (require 'repl) + (repl:top-level macro:eval) + + +File: slib.info, Node: Quick Print, Next: Debug, Prev: Repl, Up: Session Support + +Quick Print +=========== + + `(require 'qp)' + +When displaying error messages and warnings, it is paramount that the +output generated for circular lists and large data structures be +limited. This section supplies a procedure to do this. It could be +much improved. + + Notice that the neccessity for truncating output eliminates + Common-Lisp's *Note Format:: from consideration; even when + variables `*print-level*' and `*print-level*' are set, huge + strings and bit-vectors are *not* limited. + + - Procedure: qp ARG1 ... + - Procedure: qpn ARG1 ... + - Procedure: qpr ARG1 ... + `qp' writes its arguments, separated by spaces, to + `(current-output-port)'. `qp' compresses printing by substituting + `...' for substructure it does not have sufficient room to print. + `qpn' is like `qp' but outputs a newline before returning. `qpr' + is like `qpn' except that it returns its last argument. + + - Variable: *qp-width* + `*qp-width*' is the largest number of characters that `qp' should + use. + + +File: slib.info, Node: Debug, Next: Breakpoints, Prev: Quick Print, Up: Session Support + +Debug +===== + + `(require 'debug)' + +Requiring `debug' automatically requires `trace' and `break'. + +An application with its own datatypes may want to substitute its own +printer for `qp'. This example shows how to do this: + + (define qpn (lambda args) ...) + (provide 'qp) + (require 'debug) + + - Procedure: trace-all FILE + Traces (*note Trace::.) all procedures `define'd at top-level in + file `file'. + + - Procedure: break-all FILE + Breakpoints (*note Breakpoints::.) all procedures `define'd at + top-level in file `file'. + + +File: slib.info, Node: Breakpoints, Next: Trace, Prev: Debug, Up: Session Support + +Breakpoints +=========== + + `(require 'break)' + + - Function: init-debug + If your Scheme implementation does not support `break' or `abort', + a message will appear when you `(require 'break)' or `(require + 'debug)' telling you to type `(init-debug)'. This is in order to + establish a top-level continuation. Typing `(init-debug)' at top + level sets up a continuation for `break'. + + - Function: breakpoint ARG1 ... + Returns from the top level continuation and pushes the + continuation from which it was called on a continuation stack. + + - Function: continue + Pops the topmost continuation off of the continuation stack and + returns an unspecified value to it. + + - Function: continue ARG1 ... + Pops the topmost continuation off of the continuation stack and + returns ARG1 ... to it. + + - Macro: break PROC1 ... + Redefines the top-level named procedures given as arguments so that + `breakpoint' is called before calling PROC1 .... + + - Macro: break + With no arguments, makes sure that all the currently broken + identifiers are broken (even if those identifiers have been + redefined) and returns a list of the broken identifiers. + + - Macro: unbreak PROC1 ... + Turns breakpoints off for its arguments. + + - Macro: unbreak + With no arguments, unbreaks all currently broken identifiers and + returns a list of these formerly broken identifiers. + + The following routines are the procedures which actually do the +tracing when this module is supplied by SLIB, rather than natively. If +defmacros are not natively supported by your implementation, these might +be more convenient to use. + + - Function: breakf PROC + - Function: breakf PROC NAME + - Function: debug:breakf PROC + - Function: debug:breakf PROC NAME + To break, type + (set! SYMBOL (breakf SYMBOL)) + + or + (set! SYMBOL (breakf SYMBOL 'SYMBOL)) + + or + (define SYMBOL (breakf FUNCTION)) + + or + (define SYMBOL (breakf FUNCTION 'SYMBOL)) + + - Function: unbreakf PROC + - Function: debug:unbreakf PROC + To unbreak, type + (set! SYMBOL (unbreakf SYMBOL)) + + +File: slib.info, Node: Trace, Next: Getopt, Prev: Breakpoints, Up: Session Support + +Tracing +======= + + `(require 'trace)' + + - Macro: trace PROC1 ... + Traces the top-level named procedures given as arguments. + + - Macro: trace + With no arguments, makes sure that all the currently traced + identifiers are traced (even if those identifiers have been + redefined) and returns a list of the traced identifiers. + + - Macro: untrace PROC1 ... + Turns tracing off for its arguments. + + - Macro: untrace + With no arguments, untraces all currently traced identifiers and + returns a list of these formerly traced identifiers. + + The following routines are the procedures which actually do the +tracing when this module is supplied by SLIB, rather than natively. If +defmacros are not natively supported by your implementation, these might +be more convenient to use. + + - Function: tracef PROC + - Function: tracef PROC NAME + - Function: debug:tracef PROC + - Function: debug:tracef PROC NAME + To trace, type + (set! SYMBOL (tracef SYMBOL)) + + or + (set! SYMBOL (tracef SYMBOL 'SYMBOL)) + + or + (define SYMBOL (tracef FUNCTION)) + + or + (define SYMBOL (tracef FUNCTION 'SYMBOL)) + + - Function: untracef PROC + - Function: debug:untracef PROC + To untrace, type + (set! SYMBOL (untracef SYMBOL)) + diff --git a/slib.info-7 b/slib.info-7 new file mode 100644 index 0000000..2ed9fcd --- /dev/null +++ b/slib.info-7 @@ -0,0 +1,615 @@ +This is Info file slib.info, produced by Makeinfo-1.64 from the input +file slib.texi. + + This file documents SLIB, the portable Scheme library. + + Copyright (C) 1993 Todd R. Eigenschink Copyright (C) 1993, 1994, 1995 +Aubrey Jaffer + + Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + + Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + + Permission is granted to copy and distribute translations of this +manual into another language, under the above conditions for modified +versions, except that this permission notice may be stated in a +translation approved by the author. + + +File: slib.info, Node: Getopt, Next: Command Line, Prev: Trace, Up: Session Support + +Getopt +====== + + `(require 'getopt)' + + This routine implements Posix command line argument parsing. Notice +that returning values through global variables means that `getopt' is +*not* reentrant. + + - Variable: *optind* + Is the index of the current element of the command line. It is + initially one. In order to parse a new command line or reparse an + old one, *OPTING* must be reset. + + - Variable: *optarg* + Is set by getopt to the (string) option-argument of the current + option. + + - Procedure: getopt ARGC ARGV OPTSTRING + Returns the next option letter in ARGV (starting from `(vector-ref + argv *optind*)') that matches a letter in OPTSTRING. ARGV is a + vector or list of strings, the 0th of which getopt usually + ignores. ARGC is the argument count, usually the length of ARGV. + OPTSTRING is a string of recognized option characters; if a + character is followed by a colon, the option takes an argument + which may be immediately following it in the string or in the next + element of ARGV. + + *OPTIND* is the index of the next element of the ARGV vector to be + processed. It is initialized to 1 by `getopt.scm', and `getopt' + updates it when it finishes with each element of ARGV. + + `getopt' returns the next option character from ARGV that matches + a character in OPTSTRING, if there is one that matches. If the + option takes an argument, `getopt' sets the variable *OPTARG* to + the option-argument as follows: + + * If the option was the last character in the string pointed to + by an element of ARGV, then *OPTARG* contains the next + element of ARGV, and *OPTIND* is incremented by 2. If the + resulting value of *OPTIND* is greater than or equal to ARGC, + this indicates a missing option argument, and `getopt' + returns an error indication. + + * Otherwise, *OPTARG* is set to the string following the option + character in that element of ARGV, and *OPTIND* is + incremented by 1. + + If, when `getopt' is called, the string `(vector-ref argv + *optind*)' either does not begin with the character `#\-' or is + just `"-"', `getopt' returns `#f' without changing *OPTIND*. If + `(vector-ref argv *optind*)' is the string `"--"', `getopt' + returns `#f' after incrementing *OPTIND*. + + If `getopt' encounters an option character that is not contained in + OPTSTRING, it returns the question-mark `#\?' character. If it + detects a missing option argument, it returns the colon character + `#\:' if the first character of OPTSTRING was a colon, or a + question-mark character otherwise. In either case, `getopt' sets + the variable GETOPT:OPT to the option character that caused the + error. + + The special option `"--"' can be used to delimit the end of the + options; `#f' is returned, and `"--"' is skipped. + + RETURN VALUE + + `getopt' returns the next option character specified on the command + line. A colon `#\:' is returned if `getopt' detects a missing + argument and the first character of OPTSTRING was a colon `#\:'. + + A question-mark `#\?' is returned if `getopt' encounters an option + character not in OPTSTRING or detects a missing argument and the + first character of OPTSTRING was not a colon `#\:'. + + Otherwise, `getopt' returns `#f' when all command line options + have been parsed. + + Example: + #! /usr/local/bin/scm + ;;;This code is SCM specific. + (define argv (program-arguments)) + (require 'getopt) + + (define opts ":a:b:cd") + (let loop ((opt (getopt (length argv) argv opts))) + (case opt + ((#\a) (print "option a: " *optarg*)) + ((#\b) (print "option b: " *optarg*)) + ((#\c) (print "option c")) + ((#\d) (print "option d")) + ((#\?) (print "error" getopt:opt)) + ((#\:) (print "missing arg" getopt:opt)) + ((#f) (if (< *optind* (length argv)) + (print "argv[" *optind* "]=" + (list-ref argv *optind*))) + (set! *optind* (+ *optind* 1)))) + (if (< *optind* (length argv)) + (loop (getopt (length argv) argv opts)))) + + (slib:exit) + +Getopt- +======= + + - Function: getopt- ARGC ARGV OPTSTRING + The procedure `getopt--' is an extended version of `getopt' which + parses "long option names" of the form `--hold-the-onions' and + `--verbosity-level=extreme'. `Getopt--' behaves as `getopt' + except for non-empty options beginning with `--'. + + Options beginning with `--' are returned as strings rather than + characters. If a value is assigned (using `=') to a long option, + `*optarg*' is set to the value. The `=' and value are not + returned as part of the option string. + + No information is passed to `getopt--' concerning which long + options should be accepted or whether such options can take + arguments. If a long option did not have an argument, `*optarg' + will be set to `#f'. The caller is responsible for detecting and + reporting errors. + + (define opts ":-:b:") + (define argc 5) + (define argv '("foo" "-b9" "--f1" "--2=" "--g3=35234.342" "--")) + (define *optind* 1) + (define *optarg* #f) + (require 'qp) + (do ((i 5 (+ -1 i))) + ((zero? i)) + (define opt (getopt-- argc argv opts)) + (print *optind* opt *optarg*))) + -| + 2 #\b "9" + 3 "f1" #f + 4 "2" "" + 5 "g3" "35234.342" + 5 #f "35234.342" + + +File: slib.info, Node: Command Line, Next: System Interface, Prev: Getopt, Up: Session Support + +Command Line +============ + + `(require 'read-command)' + + - Function: read-command PORT + - Function: read-command + `read-command' converts a "command line" into a list of strings + suitable for parsing by `getopt'. The syntax of command lines + supported resembles that of popular "shell"s. `read-command' + updates PORT to point to the first character past the command + delimiter. + + If an end of file is encountered in the input before any + characters are found that can begin an object or comment, then an + end of file object is returned. + + The PORT argument may be omitted, in which case it defaults to the + value returned by `current-input-port'. + + The fields into which the command line is split are delimited by + whitespace as defined by `char-whitespace?'. The end of a command + is delimited by end-of-file or unescaped semicolon (;) or newline. + Any character can be literally included in a field by escaping it + with a backslach (\). + + The initial character and types of fields recognized are: + `\' + The next character has is taken literally and not interpreted + as a field delimiter. If \ is the last character before a + newline, that newline is just ignored. Processing continues + from the characters after the newline as though the backslash + and newline were not there. + + `"' + The characters up to the next unescaped " are taken literally, + according to [R4RS] rules for literal strings (*note Strings: + (r4rs)Strings.). + + `(', `%'' + One scheme expression is `read' starting with this character. + The `read' expression is evaluated, converted to a string + (using `display'), and replaces the expression in the returned + field. + + `;' + Semicolon delimits a command. Using semicolons more than one + command can appear on a line. Escaped semicolons and + semicolons inside strings do not delimit commands. + + The comment field differs from the previous fields in that it must + be the first character of a command or appear after whitespace in + order to be recognized. # can be part of fields if these + conditions are not met. For instance, `ab#c' is just the field + ab#c. + + `#' + Introduces a comment. The comment continues to the end of + the line on which the semicolon appears. Comments are + treated as whitespace by `read-dommand-line' and backslashes + before newlines in comments are also ignored. + + +File: slib.info, Node: System Interface, Next: Require, Prev: Command Line, Up: Session Support + +System Interface +================ + + If `(provided? 'getenv)': + + - Function: getenv NAME + Looks up NAME, a string, in the program environment. If NAME is + found a string of its value is returned. Otherwise, `#f' is + returned. + + If `(provided? 'system)': + + - Function: system COMMAND-STRING + Executes the COMMAND-STRING on the computer and returns the + integer status code. + + +File: slib.info, Node: Require, Next: Vicinity, Prev: System Interface, Up: Session Support + +Require +======= + + These variables and procedures are provided by all implementations. + + - Variable: *features* + Is a list of symbols denoting features supported in this + implementation. + + - Variable: *modules* + Is a list of pathnames denoting files which have been loaded. + + - Variable: *catalog* + Is an association list of features (symbols) and pathnames which + will supply those features. The pathname can be either a string + or a pair. If pathname is a pair then the first element should be + a macro feature symbol, `source', or `compiled'. The cdr of the + pathname should be either a string or a list. + + In the following three functions if FEATURE is not a symbol it is +assumed to be a pathname. + + - Function: provided? FEATURE + Returns `#t' if FEATURE is a member of `*features*' or `*modules*' + or if FEATURE is supported by a file already loaded and `#f' + otherwise. + + - Procedure: require FEATURE + If `(not (provided? FEATURE))' it is loaded if FEATURE is a + pathname or if `(assq FEATURE *catalog*)'. Otherwise an error is + signaled. + + - Procedure: provide FEATURE + Assures that FEATURE is contained in `*features*' if FEATURE is a + symbol and `*modules*' otherwise. + + - Function: require:feature->path FEATURE + Returns `#t' if FEATURE is a member of `*features*' or `*modules*' + or if FEATURE is supported by a file already loaded. Returns a + path if one was found in `*catalog*' under the feature name, and + `#f' otherwise. The path can either be a string suitable as an + argument to load or a pair as described above for *catalog*. + + Below is a list of features that are automatically determined by +`require'. For each item, `(provided? 'FEATURE)' will return `#t' if +that feature is available, and `#f' if not. + + * 'inexact + + * 'rational + + * 'real + + * 'complex + + * 'bignum + + +File: slib.info, Node: Vicinity, Next: Configuration, Prev: Require, Up: Session Support + +Vicinity +======== + + A vicinity is a descriptor for a place in the file system. Vicinities +hide from the programmer the concepts of host, volume, directory, and +version. Vicinities express only the concept of a file environment +where a file name can be resolved to a file in a system independent +manner. Vicinities can even be used on "flat" file systems (which have +no directory structure) by having the vicinity express constraints on +the file name. On most systems a vicinity would be a string. All of +these procedures are file system dependent. + + These procedures are provided by all implementations. + + - Function: make-vicinity FILENAME + Returns the vicinity of FILENAME for use by `in-vicinity'. + + - Function: program-vicinity + Returns the vicinity of the currently loading Scheme code. For an + interpreter this would be the directory containing source code. + For a compiled system (with multiple files) this would be the + directory where the object or executable files are. If no file is + currently loading it the result is undefined. *Warning:* + `program-vicinity' can return incorrectl values if your program + escapes back into a `load'. + + - Function: library-vicinity + Returns the vicinity of the shared Scheme library. + + - Function: implementation-vicinity + Returns the vicinity of the underlying Scheme implementation. This + vicinity will likely contain startup code and messages and a + compiler. + + - Function: user-vicinity + Returns the vicinity of the current directory of the user. On most + systems this is `""' (the empty string). + + - Function: in-vicinity VICINITY FILENAME + Returns a filename suitable for use by `slib:load', + `slib:load-source', `slib:load-compiled', `open-input-file', + `open-output-file', etc. The returned filename is FILENAME in + VICINITY. `in-vicinity' should allow FILENAME to override + VICINITY when FILENAME is an absolute pathname and VICINITY is + equal to the value of `(user-vicinity)'. The behavior of + `in-vicinity' when FILENAME is absolute and VICINITY is not equal + to the value of `(user-vicinity)' is unspecified. For most systems + `in-vicinity' can be `string-append'. + + - Function: sub-vicinity VICINITY NAME + Returns the vicinity of VICINITY restricted to NAME. This is used + for large systems where names of files in subsystems could + conflict. On systems with directory structure `sub-vicinity' will + return a pathname of the subdirectory NAME of VICINITY. + + +File: slib.info, Node: Configuration, Next: Input/Output, Prev: Vicinity, Up: Session Support + +Configuration +============= + + These constants and procedures describe characteristics of the Scheme +and underlying operating system. They are provided by all +implementations. + + - Constant: char-code-limit + An integer 1 larger that the largest value which can be returned by + `char->integer'. + + - Constant: most-positive-fixnum + The immediate integer closest to positive infinity. + + - Constant: slib:tab + The tab character. + + - Constant: slib:form-feed + The form-feed character. + + - Function: software-type + Returns a symbol denoting the generic operating system type. For + instance, `unix', `vms', `macos', `amiga', or `ms-dos'. + + - Function: slib:report-version + Displays the versions of SLIB and the underlying Scheme + implementation and the name of the operating system. An + unspecified value is returned. + + (slib:report-version) => slib "2a3" on scm "4e1" on unix + + - Function: slib:report + Displays the information of `(slib:report-version)' followed by + almost all the information neccessary for submitting a problem + report. An unspecified value is returned. + + - Function: slib:report #T + provides a more verbose listing. + + - Function: slib:report FILENAME + Writes the report to file `filename'. + + (slib:report) + => + slib "2a3" on scm "4e1" on unix + (implementation-vicinity) is "/usr/local/src/scm/" + (library-vicinity) is "/usr/local/lib/slib/" + (scheme-file-suffix) is ".scm" + implementation *features* : + bignum complex real rational + inexact vicinity ed getenv + tmpnam system abort transcript + with-file ieee-p1178 rev4-report rev4-optional-procedures + hash object-hash delay eval + dynamic-wind multiarg-apply multiarg/and- logical + defmacro string-port source array-for-each + array full-continuation char-ready? line-i/o + i/o-extensions pipe + implementation *catalog* : + (rev4-optional-procedures . "/usr/local/lib/slib/sc4opt") + ... + + +File: slib.info, Node: Input/Output, Next: Legacy, Prev: Configuration, Up: Session Support + +Input/Output +============ + + These procedures are provided by all implementations. + + - Procedure: file-exists? FILENAME + Returns `#t' if the specified file exists. Otherwise, returns + `#f'. If the underlying implementation does not support this + feature then `#f' is always returned. + + - Procedure: delete-file FILENAME + Deletes the file specified by FILENAME. If FILENAME can not be + deleted, `#f' is returned. Otherwise, `#t' is returned. + + - Procedure: tmpnam + Returns a pathname for a file which will likely not be used by any + other process. Successive calls to `(tmpnam)' will return + different pathnames. + + - Procedure: current-error-port + Returns the current port to which diagnostic and error output is + directed. + + - Procedure: force-output + - Procedure: force-output PORT + Forces any pending output on PORT to be delivered to the output + device and returns an unspecified value. The PORT argument may be + omitted, in which case it defaults to the value returned by + `(current-output-port)'. + + - Procedure: output-port-width + - Procedure: output-port-width PORT + Returns the width of PORT, which defaults to + `(current-output-port)' if absent. If the width cannot be + determined 79 is returned. + + - Procedure: output-port-height + - Procedure: output-port-height PORT + Returns the height of PORT, which defaults to + `(current-output-port)' if absent. If the height cannot be + determined 24 is returned. + + +File: slib.info, Node: Legacy, Next: System, Prev: Input/Output, Up: Session Support + +Legacy +====== + + - Function: identity X + IDENTITY returns its argument. + + Example: + (identity 3) + => 3 + (identity '(foo bar)) + => (foo bar) + (map identity LST) + == (copy-list LST) + + These were present in Scheme until R4RS (*note Language changes: +(r4rs)Notes.). + + - Constant: t + Derfined as `#t'. + + - Constant: nil + Defined as `#f'. + + - Function: last-pair L + Returns the last pair in the list L. Example: + (last-pair (cons 1 2)) + => (1 . 2) + (last-pair '(1 2)) + => (2) + == (cons 2 '()) + + +File: slib.info, Node: System, Prev: Legacy, Up: Session Support + +System +====== + + These procedures are provided by all implementations. + + - Procedure: slib:load-source NAME + Loads a file of Scheme source code from NAME with the default + filename extension used in SLIB. For instance if the filename + extension used in SLIB is `.scm' then `(slib:load-source "foo")' + will load from file `foo.scm'. + + - Procedure: slib:load-compiled NAME + On implementations which support separtely loadable compiled + modules, loads a file of compiled code from NAME with the + implementation's filename extension for compiled code appended. + + - Procedure: slib:load NAME + Loads a file of Scheme source or compiled code from NAME with the + appropriate suffixes appended. If both source and compiled code + are present with the appropriate names then the implementation + will load just one. It is up to the implementation to choose + which one will be loaded. + + If an implementation does not support compiled code then + `slib:load' will be identical to `slib:load-source'. + + - Procedure: slib:eval OBJ + `eval' returns the value of OBJ evaluated in the current top level + environment. + + - Procedure: slib:eval-load FILENAME EVAL + FILENAME should be a string. If filename names an existing file, + the Scheme source code expressions and definitions are read from + the file and EVAL called with them sequentially. The + `slib:eval-load' procedure does not affect the values returned by + `current-input-port' and `current-output-port'. + + - Procedure: slib:error ARG1 ARG2 ... + Outputs an error message containing the arguments, aborts + evaluation of the current form and responds in a system dependent + way to the error. Typical responses are to abort the program or + to enter a read-eval-print loop. + + - Procedure: slib:exit N + - Procedure: slib:exit + Exits from the Scheme session returning status N to the system. + If N is omitted or `#t', a success status is returned to the + system (if possible). If N is `#f' a failure is returned to the + system (if possible). If N is an integer, then N is returned to + the system (if possible). If the Scheme session cannot exit an + unspecified value is returned from `slib:exit'. + + +File: slib.info, Node: Optional SLIB Packages, Next: Procedure and Macro Index, Prev: Session Support, Up: Top + +Optional SLIB Packages +********************** + + Several Scheme packages have been written using SLIB. There are +several reasons why a package might not be included in the SLIB +distribution: + * Because it requires special hardware or software which is not + universal. + + * Because it is large and of limited interest to most Scheme users. + + * Because it has copying terms different enough from the other SLIB + packages that its inclusion would cause confusion. + + * Because it is an application program, rather than a library module. + + * Because I have been too busy to integrate it. + + Once an optional package is installed (and an entry added to +`*catalog*', the `require' mechanism allows it to be called up and used +as easily as any other SLIB package. Some optional packages (for which +`*catalog*' already has entries) available from SLIB sites are: + +SLIB-PSD is a portable debugger for Scheme (requires emacs editor). + ftp-swiss.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz + + With PSD, you can run a Scheme program in an Emacs buffer, set + breakpoints, single step evaluation and access and modify the + program's variables. It works by instrumenting the original source + code, so it should run with any R4RS compliant Scheme. It has been + tested with SCM, Elk 1.5, and the sci interpreter in the Scheme->C + system, but should work with other Schemes with a minimal amount + of porting, if at all. Includes documentation and user's manual. + Written by Pertti Kellom\"aki, pk@cs.tut.fi. The Lisp Pointers + article describing PSD (Lisp Pointers VI(1):15-23, January-March + 1993) is available as + http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html + +SLIB-SCHELOG is an embedding of Prolog in Scheme. + ftp-swiss.ai.mit.edu:pub/scm/slib-schelog.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/slib-schelog.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-schelog.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-schelog.tar.gz + diff --git a/slib.info-8 b/slib.info-8 new file mode 100644 index 0000000..670e9c1 --- /dev/null +++ b/slib.info-8 @@ -0,0 +1,570 @@ +This is Info file slib.info, produced by Makeinfo-1.64 from the input +file slib.texi. + + This file documents SLIB, the portable Scheme library. + + Copyright (C) 1993 Todd R. Eigenschink Copyright (C) 1993, 1994, 1995 +Aubrey Jaffer + + Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + + Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + + Permission is granted to copy and distribute translations of this +manual into another language, under the above conditions for modified +versions, except that this permission notice may be stated in a +translation approved by the author. + + +File: slib.info, Node: Procedure and Macro Index, Next: Variable Index, Prev: Optional SLIB Packages, Up: Top + +Procedure and Macro Index +************************* + + This is an alphabetical list of all the procedures and macros in SLIB. + +* Menu: + +* -: Multi-argument / and -. +* -1+: Rev2 Procedures. +* /: Multi-argument / and -. +* 1+: Rev2 Procedures. +* <=?: Rev2 Procedures. +* =?: Rev2 Procedures. +* >?: Rev2 Procedures. +* TAG: Structures. +* add-domain: Database Utilities. +* add-process!: Multi-Processing. +* add-setter: Setters. +* adjoin: Lists as sets. +* adjoin-parameters!: Parameter lists. +* alist->wt-tree: Construction of Weight-Balanced Trees. +* alist-associator: Association Lists. +* alist-for-each: Association Lists. +* alist-inquirer: Association Lists. +* alist-map: Association Lists. +* alist-remover: Association Lists. +* and?: Non-List functions. +* any?: Collections. +* append!: Rev2 Procedures. +* apply: Multi-argument Apply. +* array-1d-ref: Arrays. +* array-1d-set!: Arrays. +* array-2d-ref: Arrays. +* array-2d-set!: Arrays. +* array-3d-ref: Arrays. +* array-3d-set!: Arrays. +* array-copy!: Array Mapping. +* array-dimensions: Arrays. +* array-for-each: Array Mapping. +* array-in-bounds?: Arrays. +* array-indexes: Array Mapping. +* array-map!: Array Mapping. +* array-rank: Arrays. +* array-ref: Arrays. +* array-set!: Arrays. +* array-shape: Arrays. +* array?: Arrays. +* asctime: Time. +* ash: Bit-Twiddling. +* atom?: Non-List functions. +* batch:apply-chop-to-fit: Batch. +* batch:call-with-output-script: Batch. +* batch:comment: Batch. +* batch:delete-file: Batch. +* batch:initialize!: Batch. +* batch:lines->file: Batch. +* batch:rename-file: Batch. +* batch:run-script: Batch. +* batch:system: Batch. +* batch:try-system: Batch. +* bit-extract: Bit-Twiddling. +* break: Breakpoints. +* break-all: Debug. +* breakf: Breakpoints. +* breakpoint: Breakpoints. +* butlast: Lists as sequences. +* call-with-dynamic-binding: Dynamic Data Type. +* call-with-input-string: String Ports. +* call-with-output-string: String Ports. +* call-with-values: Values. +* capture-syntactic-environment: Syntactic Closures. +* cart-prod-tables: Relational Database Operations. +* chap:next-string: Chapter Ordering. +* chap:string<=?: Chapter Ordering. +* chap:string=?: Chapter Ordering. +* chap:string>?: Chapter Ordering. +* check-parameters: Parameter lists. +* close-base: Base Table. +* close-database: Relational Database Operations. +* close-table: Table Operations. +* coerce: Non-List functions. +* collection?: Collections. +* continue: Breakpoints. +* copy-list: List construction. +* copy-tree: Tree Operations. +* create-database <1>: Database Utilities. +* create-database: Creating and Opening Relational Databases. +* create-report: Database Utilities. +* create-table: Relational Database Operations. +* create-view: Relational Database Operations. +* ctime: Time. +* current-error-port: Input/Output. +* current-time: Time. +* debug:breakf: Breakpoints. +* debug:tracef: Trace. +* debug:unbreakf: Breakpoints. +* debug:untracef: Trace. +* decode-universal-time: CLTime. +* define-access-operation: Setters. +* define-operation: Yasos interface. +* define-predicate: Yasos interface. +* define-record: Structures. +* define-syntax: Macro by Example. +* define-tables: Database Utilities. +* defmacro: Defmacro. +* defmacro:eval: Defmacro. +* defmacro:expand*: Defmacro. +* defmacro:load: Defmacro. +* defmacro?: Defmacro. +* delete <1>: Destructive list operations. +* delete: Base Table. +* delete-domain: Database Utilities. +* delete-file: Input/Output. +* delete-if: Destructive list operations. +* delete-if-not: Destructive list operations. +* delete-table: Relational Database Operations. +* dequeue!: Queues. +* difftime: Time. +* do-elts: Collections. +* do-keys: Collections. +* domain-checker: Database Utilities. +* dynamic-ref: Dynamic Data Type. +* dynamic-set!: Dynamic Data Type. +* dynamic-wind: Dynamic-Wind. +* dynamic?: Dynamic Data Type. +* empty?: Collections. +* encode-universal-time: CLTime. +* enquque!: Queues. +* every: Lists as sets. +* every?: Collections. +* extended-euclid: Modular Arithmetic. +* factor: Prime Factorization. +* file-exists?: Input/Output. +* fill-empty-parameters: Parameter lists. +* find-if: Lists as sets. +* find-string-from-port?: String Search. +* fluid-let: Fluid-Let. +* for-each-elt: Collections. +* for-each-key <1>: Base Table. +* for-each-key: Collections. +* for-each-row: Table Operations. +* force-output: Input/Output. +* format: Format Interface. +* fprintf: Standard Formatted Output. +* fscanf: Standard Formatted Input. +* generic-write: Generic-Write. +* gentemp: Defmacro. +* get: Table Operations. +* get*: Table Operations. +* get-decoded-time: CLTime. +* get-method: Object. +* get-universal-time: CLTime. +* getenv: System Interface. +* getopt: Getopt. +* getopt-: Getopt. +* getopt->arglist: Parameter lists. +* getopt->parameter-list: Parameter lists. +* gmtime: Time. +* has-duplicates?: Lists as sets. +* hash: Hashing. +* hash-associator: Hash Tables. +* hash-for-each: Hash Tables. +* hash-inquirer: Hash Tables. +* hash-map: Hash Tables. +* hash-remover: Hash Tables. +* hashq: Hashing. +* hashv: Hashing. +* heap-extract-max!: Priority Queues. +* heap-insert!: Priority Queues. +* heap-length: Priority Queues. +* identifier=?: Syntactic Closures. +* identifier?: Syntactic Closures. +* identity: Legacy. +* implementation-vicinity: Vicinity. +* in-vicinity: Vicinity. +* init-debug: Breakpoints. +* integer-expt: Bit-Twiddling. +* integer-length: Bit-Twiddling. +* integer-sqrt: Root Finding. +* intersection: Lists as sets. +* jacobi-symbol: Prime Factorization. +* kill-process!: Multi-Processing. +* kill-table: Base Table. +* laguerre:find-polynomial-root: Root Finding. +* laguerre:find-root: Root Finding. +* last: Lists as sequences. +* last-pair: Legacy. +* library-vicinity: Vicinity. +* list*: List construction. +* list->string: Rev4 Optional Procedures. +* list->vector: Rev4 Optional Procedures. +* list-tail: Rev4 Optional Procedures. +* load-option: Weight-Balanced Trees. +* localtime: Time. +* logand: Bit-Twiddling. +* logbit?: Bit-Twiddling. +* logcount: Bit-Twiddling. +* logior: Bit-Twiddling. +* lognot: Bit-Twiddling. +* logtest: Bit-Twiddling. +* logxor: Bit-Twiddling. +* macro:eval <1>: Syntax-Case Macros. +* macro:eval <2>: Syntactic Closures. +* macro:eval <3>: Macros That Work. +* macro:eval: R4RS Macros. +* macro:expand <1>: Syntax-Case Macros. +* macro:expand <2>: Syntactic Closures. +* macro:expand <3>: Macros That Work. +* macro:expand: R4RS Macros. +* macro:load <1>: Syntax-Case Macros. +* macro:load <2>: Syntactic Closures. +* macro:load <3>: Macros That Work. +* macro:load: R4RS Macros. +* macroexpand: Defmacro. +* macroexpand-1: Defmacro. +* macwork:eval: Macros That Work. +* macwork:expand: Macros That Work. +* macwork:load: Macros That Work. +* make-: Structures. +* make-array: Arrays. +* make-base: Base Table. +* make-command-server: Database Utilities. +* make-dynamic: Dynamic Data Type. +* make-generic-method: Object. +* make-generic-predicate: Object. +* make-getter: Base Table. +* make-hash-table: Hash Tables. +* make-heap: Priority Queues. +* make-key->list: Base Table. +* make-key-extractor: Base Table. +* make-keyifier-1: Base Table. +* make-list: List construction. +* make-list-keyifier: Base Table. +* make-method!: Object. +* make-object: Object. +* make-parameter-list: Parameter lists. +* make-port-crc: Cyclic Checksum. +* make-predicate!: Object. +* make-promise: Promises. +* make-putter: Base Table. +* make-queue: Queues. +* make-random-state: Random Numbers. +* make-record-type: Records. +* make-relational-system: Creating and Opening Relational Databases. +* make-shared-array: Arrays. +* make-sierpinski-indexer: Hashing. +* make-syntactic-closure: Syntactic Closures. +* make-table: Base Table. +* make-vicinity: Vicinity. +* make-wt-tree: Construction of Weight-Balanced Trees. +* make-wt-tree-type: Construction of Weight-Balanced Trees. +* map-elts: Collections. +* map-key: Base Table. +* map-keys: Collections. +* member-if: Lists as sets. +* merge: Sorting. +* merge!: Sorting. +* mktime: Time. +* modular:: Modular Arithmetic. +* modular:*: Modular Arithmetic. +* modular:+: Modular Arithmetic. +* modular:expt: Modular Arithmetic. +* modular:invert: Modular Arithmetic. +* modular:invertable?: Modular Arithmetic. +* modular:negate: Modular Arithmetic. +* modular:normalize: Modular Arithmetic. +* modulus->integer: Modular Arithmetic. +* must-be-first: Batch. +* must-be-last: Batch. +* nconc: Destructive list operations. +* newton:find-root: Root Finding. +* newtown:find-integer-root: Root Finding. +* notany: Lists as sets. +* notevery: Lists as sets. +* nreverse: Destructive list operations. +* nthcdr: Lists as sequences. +* object: Yasos interface. +* object->string: Object-To-String. +* object-with-ancestors: Yasos interface. +* object?: Object. +* offset-time: Time. +* open-base: Base Table. +* open-database <1>: Database Utilities. +* open-database: Creating and Opening Relational Databases. +* open-database!: Database Utilities. +* open-table <1>: Relational Database Operations. +* open-table: Base Table. +* operate-as: Yasos interface. +* or?: Non-List functions. +* ordered-for-each-key: Base Table. +* os->batch-dialect: Batch. +* output-port-height: Input/Output. +* output-port-width: Input/Output. +* parameter-list->arglist: Parameter lists. +* parameter-list-expand: Parameter lists. +* parameter-list-ref: Parameter lists. +* plot!: Plotting. +* position: Lists as sequences. +* pprint-file: Pretty-Print. +* pprint-filter-file: Pretty-Print. +* predicate->asso: Association Lists. +* predicate->hash: Hash Tables. +* predicate->hash-asso: Hash Tables. +* present?: Base Table. +* pretty-print: Pretty-Print. +* prime:trials: Prime Factorization. +* prime?: Prime Factorization. +* primes<: Prime Testing and Generation. +* primes>: Prime Testing and Generation. +* print: Yasos interface. +* printf: Standard Formatted Output. +* probably-prime?: Prime Testing and Generation. +* process:schedule!: Multi-Processing. +* program-vicinity: Vicinity. +* project-table: Relational Database Operations. +* provide: Require. +* provided?: Require. +* qp: Quick Print. +* qpn: Quick Print. +* qpr: Quick Print. +* queue-empty?: Queues. +* queue-front: Queues. +* queue-pop!: Queues. +* queue-push!: Queues. +* queue-rear: Queues. +* queue?: Queues. +* random: Random Numbers. +* random:exp: Random Numbers. +* random:hollow-sphere!: Random Numbers. +* random:normal: Random Numbers. +* random:normal-vector!: Random Numbers. +* random:solid-sphere!: Random Numbers. +* random:uniform: Random Numbers. +* rationalize: Rationalize. +* read-command: Command Line. +* read-line: Line I/O. +* read-line!: Line I/O. +* record-accessor: Records. +* record-constructor: Records. +* record-modifier: Records. +* record-predicate: Records. +* record-type-descriptor: Records. +* record-type-field-names: Records. +* record-type-name: Records. +* record?: Records. +* reduce <1>: Lists as sequences. +* reduce: Collections. +* reduce-init: Lists as sequences. +* remove: Lists as sets. +* remove-if: Lists as sets. +* remove-if-not: Lists as sets. +* remove-setter-for: Setters. +* repl:quit: Repl. +* repl:top-level: Repl. +* replace-suffix: Batch. +* require: Require. +* require:feature->path: Require. +* restrict-table: Relational Database Operations. +* row:delete: Table Operations. +* row:delete*: Table Operations. +* row:insert: Table Operations. +* row:insert*: Table Operations. +* row:remove: Table Operations. +* row:remove*: Table Operations. +* row:retrieve: Table Operations. +* row:retrieve*: Table Operations. +* row:update: Table Operations. +* row:update*: Table Operations. +* scanf: Standard Formatted Input. +* scanf-read-list: Standard Formatted Input. +* set: Setters. +* set-: Structures. +* set-difference: Lists as sets. +* setter: Setters. +* Setter: Collections. +* singleton-wt-tree: Construction of Weight-Balanced Trees. +* size <1>: Yasos interface. +* size: Collections. +* slib:error: System. +* slib:eval: System. +* slib:eval-load: System. +* slib:exit: System. +* slib:load: System. +* slib:load-compiled: System. +* slib:load-source: System. +* slib:report: Configuration. +* slib:report-version: Configuration. +* software-type: Configuration. +* some: Lists as sets. +* sort: Sorting. +* sort!: Sorting. +* sorted?: Sorting. +* soundex: Hashing. +* sprintf: Standard Formatted Output. +* sscanf: Standard Formatted Input. +* string->list: Rev4 Optional Procedures. +* string-capitalize: String-Case. +* string-captialize!: String-Case. +* string-copy: Rev4 Optional Procedures. +* string-downcase: String-Case. +* string-downcase!: String-Case. +* string-fill!: Rev4 Optional Procedures. +* string-index: String Search. +* string-join: Batch. +* string-null?: Rev2 Procedures. +* string-upcase: String-Case. +* string-upcase!: String-Case. +* sub-vicinity: Vicinity. +* subst: Tree Operations. +* substq: Tree Operations. +* substring-fill!: Rev2 Procedures. +* substring-move-left!: Rev2 Procedures. +* substring-move-right!: Rev2 Procedures. +* substring?: String Search. +* substv: Tree Operations. +* supported-key-type?: Base Table. +* supported-type?: Base Table. +* symmetric:modulus: Modular Arithmetic. +* sync-base: Base Table. +* syncase:eval: Syntax-Case Macros. +* syncase:expand: Syntax-Case Macros. +* syncase:load: Syntax-Case Macros. +* synclo:eval: Syntactic Closures. +* synclo:expand: Syntactic Closures. +* synclo:load: Syntactic Closures. +* syntax-rules: Macro by Example. +* system: System Interface. +* table-exists?: Relational Database Operations. +* tek40:draw: Tektronix Graphics Support. +* tek40:graphics: Tektronix Graphics Support. +* tek40:init: Tektronix Graphics Support. +* tek40:linetype: Tektronix Graphics Support. +* tek40:move: Tektronix Graphics Support. +* tek40:put-text: Tektronix Graphics Support. +* tek40:reset: Tektronix Graphics Support. +* tek40:text: Tektronix Graphics Support. +* tek41:draw: Tektronix Graphics Support. +* tek41:encode-int: Tektronix Graphics Support. +* tek41:encode-x-y: Tektronix Graphics Support. +* tek41:graphics: Tektronix Graphics Support. +* tek41:init: Tektronix Graphics Support. +* tek41:move: Tektronix Graphics Support. +* tek41:point: Tektronix Graphics Support. +* tek41:reset: Tektronix Graphics Support. +* tmpnam: Input/Output. +* topological-sort: Topological Sort. +* trace: Trace. +* trace-all: Debug. +* tracef: Trace. +* transcript-off: Transcripts. +* transcript-on: Transcripts. +* transformer: Syntactic Closures. +* tsort: Topological Sort. +* two-arg:-: Multi-argument / and -. +* two-arg:/: Multi-argument / and -. +* two-arg:apply: Multi-argument Apply. +* type-of: Non-List functions. +* tzset: Time. +* unbreak: Breakpoints. +* unbreakf: Breakpoints. +* union: Lists as sets. +* unmake-method!: Object. +* untrace: Trace. +* untracef: Trace. +* user-vicinity: Vicinity. +* values: Values. +* variant-case: Structures. +* vector->list: Rev4 Optional Procedures. +* vector-fill!: Rev4 Optional Procedures. +* with-input-from-file: With-File. +* with-output-to-file: With-File. +* write-base: Base Table. +* write-database: Relational Database Operations. +* write-line: Line I/O. +* wt-tree/add: Basic Operations on Weight-Balanced Trees. +* wt-tree/add!: Basic Operations on Weight-Balanced Trees. +* wt-tree/delete: Basic Operations on Weight-Balanced Trees. +* wt-tree/delete!: Basic Operations on Weight-Balanced Trees. +* wt-tree/delete-min: Indexing Operations on Weight-Balanced Trees. +* wt-tree/delete-min!: Indexing Operations on Weight-Balanced Trees. +* wt-tree/difference: Advanced Operations on Weight-Balanced Trees. +* wt-tree/empty?: Basic Operations on Weight-Balanced Trees. +* wt-tree/fold: Advanced Operations on Weight-Balanced Trees. +* wt-tree/for-each: Advanced Operations on Weight-Balanced Trees. +* wt-tree/index: Indexing Operations on Weight-Balanced Trees. +* wt-tree/index-datum: Indexing Operations on Weight-Balanced Trees. +* wt-tree/index-pair: Indexing Operations on Weight-Balanced Trees. +* wt-tree/intersection: Advanced Operations on Weight-Balanced Trees. +* wt-tree/lookup: Basic Operations on Weight-Balanced Trees. +* wt-tree/member?: Basic Operations on Weight-Balanced Trees. +* wt-tree/min: Indexing Operations on Weight-Balanced Trees. +* wt-tree/min-datum: Indexing Operations on Weight-Balanced Trees. +* wt-tree/min-pair: Indexing Operations on Weight-Balanced Trees. +* wt-tree/rank: Indexing Operations on Weight-Balanced Trees. +* wt-tree/set-equal?: Advanced Operations on Weight-Balanced Trees. +* wt-tree/size: Basic Operations on Weight-Balanced Trees. +* wt-tree/split<: Advanced Operations on Weight-Balanced Trees. +* wt-tree/split>: Advanced Operations on Weight-Balanced Trees. +* wt-tree/subset?: Advanced Operations on Weight-Balanced Trees. +* wt-tree/union: Advanced Operations on Weight-Balanced Trees. +* wt-tree?: Basic Operations on Weight-Balanced Trees. + + +File: slib.info, Node: Variable Index, Prev: Procedure and Macro Index, Up: Top + +Variable Index +************** + + This is an alphabetical list of all the global variables in SLIB. + +* Menu: + +* *catalog*: Require. +* *features*: Require. +* *modules*: Require. +* *optarg*: Getopt. +* *optind*: Getopt. +* *qp-width*: Quick Print. +* *random-state*: Random Numbers. +* *timezone*: Time. +* batch:platform: Batch. +* catalog-id: Base Table. +* char-code-limit: Configuration. +* charplot:height: Plotting. +* charplot:width: Plotting. +* column-domains: Table Operations. +* column-foreigns: Table Operations. +* column-names: Table Operations. +* column-types: Table Operations. +* most-positive-fixnum: Configuration. +* nil: Legacy. +* number-wt-type: Construction of Weight-Balanced Trees. +* primary-limit: Table Operations. +* slib:form-feed: Configuration. +* slib:tab: Configuration. +* stderr: Standard Formatted I/O. +* stdin: Standard Formatted I/O. +* stdout: Standard Formatted I/O. +* string-wt-type: Construction of Weight-Balanced Trees. +* t: Legacy. + + diff --git a/slib.texi b/slib.texi new file mode 100644 index 0000000..1d41fdc --- /dev/null +++ b/slib.texi @@ -0,0 +1,9058 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename slib.info +@settitle SLIB +@setchapternewpage on +@c Choices for setchapternewpage are {on,off,odd}. +@paragraphindent 2 +@c %**end of header + +@iftex +@finalout +@c DL: lose the egregious vertical whitespace, esp. around examples +@c but paras in @defun-like things don't have parindent +@parskip 4pt plus 1pt +@end iftex + +@ifinfo +This file documents SLIB, the portable Scheme library. + +Copyright (C) 1993 Todd R. Eigenschink +Copyright (C) 1993, 1994, 1995 Aubrey Jaffer + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@ignore +Permission is granted to process this file through TeX and print the +results, provided the printed document carries copying permission +notice identical to this one except for the removal of this paragraph +(this paragraph not being relevant to the printed manual). + +@end ignore +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation approved +by the author. +@end ifinfo + +@titlepage +@title SLIB +@subtitle The Portable Scheme Library +@subtitle Version 2a3 +@subtitle June 1995 +@author by Todd R. Eigenschink, Dave Love, and Aubrey Jaffer + +@page +@vskip 0pt plus 1filll +Copyright @copyright{} 1993, 1994, 1995 Todd R. Eigenschink and Aubrey Jaffer + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation approved +by the author. +@end titlepage + + + + + +@node Top, Overview, (dir), (dir) + +@ifinfo +This file documents SLIB, the portable Scheme library. + +@heading Good Engineering is 1% inspiration and 99% documentation. + +Herein lies the good part. Many thanks to Todd Eigenschink + (who thanks Dave Love ) +for creating @file{slib.texi}. I have learned much from their example. + +Aubrey Jaffer +jaffer@@ai.mit.edu +@end ifinfo + + +@menu +* Overview:: What is SLIB? + +* Data Structures:: Various data structures. +* Macros:: Extensions to Scheme syntax. +* Numerics:: +* Procedures:: Miscellaneous utility procedures. +* Standards Support:: Support for Scheme Standards. +* Session Support:: Debugging, Pathnames, Require, etc. + +* Optional SLIB Packages:: +* Procedure and Macro Index:: +* Variable Index:: +@end menu + + +@node Overview, Data Structures, Top, Top +@chapter Overview + +SLIB is a portable Scheme library meant to provide compatibility and +utility functions for all standard Scheme implementations, and fixes +several implementations which are non-conforming. SLIB conforms to +@cite{Revised^4 Report on the Algorithmic Language Scheme} and the IEEE +P1178 specification. SLIB supports Unix and similar systems, VMS, and +MS-DOS.@refill + +For a summary of what each file contains, see the file @file{README}. +For a list of the features that have changed since the last SLIB +release, see the file @file{ANNOUNCE}. For a list of the features that +have changed over time, see the file @file{ChangeLog}. + +The maintainer can be reached as @samp{jaffer@@ai.mit.edu}. + +@menu +* Installation:: How to install SLIB on your system. +* Porting:: SLIB to new platforms +* Coding Standards:: How to write modules for SLIB. +* Copyrights:: Intellectual propery issues. +* Manual Conventions:: Conventions used in this manual. +@end menu + +@node Installation, Porting, Overview, Overview +@section Installation + +Check the manifest in @file{README} to find a configuration file for +your Scheme implementation. Initialization files for most IEEE P1178 +compliant Scheme Implementations are included with this distribution. + +If the Scheme implementation supports @code{getenv}, then the value of +the shell environment variable @var{SCHEME_LIBRARY_PATH} will be used +for @code{(library-vicinity)} if it is defined. Currently, Chez, Elk, +MITScheme, scheme->c, VSCM, and SCM support @code{getenv}. + +You should check the definitions of @code{software-type}, +@code{scheme-implementation-version}, +@iftex +@* +@end iftex +@code{implementation-vicinity}, +and @code{library-vicinity} in the initialization file. There are +comments in the file for how to configure it. + +Once this is done you can modify the startup file for your Scheme +implementation to @code{load} this initialization file. SLIB is then +installed. + +Multiple implementations of Scheme can all use the same SLIB directory. +Simply configure each implementation's initialization file as outlined +above. + +The SCM implementation does not require any initialization file as SLIB +support is already built in to SCM. See the documentation with SCM for +installation instructions. + +SLIB includes methods to create heap images for the VSCM and Scheme48 +implementations. The instructions for creating a VSCM image are in +comments in @file{vscm.init}. To make a Scheme48 image, @code{cd} to +the SLIB directory and type @code{make slib48}. This will also create a +shell script with the name @code{slib48} which will invoke the saved +image. + +@node Porting, Coding Standards, Installation, Overview +@section Porting + +If there is no initialization file for your Scheme implementation, you +will have to create one. Your Scheme implementation must be largely +compliant with @cite{IEEE Std 1178-1990} or @cite{Revised^4 Report on +the Algorithmic Language Scheme} to support SLIB. + +@file{Template.scm} is an example configuration file. The comments +inside will direct you on how to customize it to reflect your system. +Give your new initialization file the implementation's name with +@file{.init} appended. For instance, if you were porting +@code{foo-scheme} then the initialization file might be called +@file{foo.init}. + +Your customized version should then be loaded as part of your scheme +implementation's initialization. It will load @file{require.scm} +(@xref{Require}) from the library; this will allow the use of +@code{provide}, @code{provided?}, and @code{require} along with the +@dfn{vicinity} functions (@code{vicinity} functions are documented in +the section on Require. @xref{Require}). The rest of the library will +then be accessible in a system independent fashion.@refill + +Please mail new working configuration files to @code{jaffer@@ai.mit.edu} +so that they can be included in the SLIB distribution.@refill + +@node Coding Standards, Copyrights, Porting, Overview +@section Coding Standards + +All library packages are written in IEEE P1178 Scheme and assume that a +configuration file and @file{require.scm} package have already been +loaded. Other versions of Scheme can be supported in library packages +as well by using, for example, @code{(provided? 'rev3-report)} or +@code{(require 'rev3-report)} (@xref{Require}).@refill + +@file{require.scm} defines @code{*catalog*}, an association list of +module names and filenames. When a new package is added to the library, +an entry should be added to @file{require.scm}. Local packages can also +be added to @code{*catalog*} and even shadow entries already in the +table.@refill + +The module name and @samp{:} should prefix each symbol defined in the +package. Definitions for external use should then be exported by having +@code{(define foo module-name:foo)}.@refill + +Submitted code should not duplicate routines which are already in SLIB +files. Use @code{require} to force those features to be supported in +your package. Care should be taken that there are no circularities in +the @code{require}s and @code{load}s between the library +packages.@refill + +Documentation should be provided in Emacs Texinfo format if possible, +But documentation must be provided. + +Your package will be released sooner with SLIB if you send me a file +which tests your code. Please run this test @emph{before} you send me +the code! + +@subheading Modifications + +Please document your changes. A line or two for @file{ChangeLog} is +sufficient for simple fixes or extensions. Look at the format of +@file{ChangeLog} to see what information is desired. Please send me +@code{diff} files from the latest SLIB distribution (remember to send +@code{diff}s of @file{slib.texi} and @file{ChangeLog}). This makes for +less email traffic and makes it easier for me to integrate when more +than one person is changing a file (this happens a lot with +@file{slib.texi} and @samp{*.init} files). + +If someone else wrote a package you want to significantly modify, please +try to contact the author, who may be working on a new version. This +will insure against wasting effort on obsolete versions. + +Please @emph{do not} reformat the source code with your favorite +beautifier, make 10 fixes, and send me the resulting source code. I do +not have the time to fish through 10000 diffs to find your 10 real fixes. + +@node Copyrights, Manual Conventions, Coding Standards, Overview +@section Copyrights + +This section has instructions for SLIB authors regarding copyrights. + +Each package in SLIB must either be in the public domain, or come with a +statement of terms permitting users to copy, redistribute and modify it. +The comments at the beginning of @file{require.scm} and +@file{macwork.scm} illustrate copyright and appropriate terms. + +If your code or changes amount to less than about 10 lines, you do not +need to add your copyright or send a disclaimer. + +@subheading Putting code into the Public Domain + +In order to put code in the public domain you should sign a copyright +disclaimer and send it to the SLIB maintainer. Contact +jaffer@@ai.mit.edu for the address to mail the disclaimer to. + +@quotation +I, @var{name}, hereby affirm that I have placed the software package +@var{name} in the public domain. + +I affirm that I am the sole author and sole copyright holder for the +software package, that I have the right to place this software package +in the public domain, and that I will do nothing to undermine this +status in the future. + +@flushright + @var{signature and date} +@end flushright +@end quotation + +This wording assumes that you are the sole author. If you are not the +sole author, the wording needs to be different. If you don't want to be +bothered with sending a letter every time you release or modify a +module, make your letter say that it also applies to your future +revisions of that module. + +Make sure no employer has any claim to the copyright on the work you are +submitting. If there is any doubt, create a copyright disclaimer and +have your employer sign it. Mail the signed disclaimer to the SLIB +maintainer. Contact jaffer@@ai.mit.edu for the address to mail the +disclaimer to. An example disclaimer follows. + +@subheading Explicit copying terms + +@noindent +If you submit more than about 10 lines of code which you are not placing +into the Public Domain (by sending me a disclaimer) you need to: + +@itemize @bullet +@item +Arrange that your name appears in a copyright line for the appropriate +year. Multiple copyright lines are acceptable. +@item +With your copyright line, specify any terms you require to be different +from those already in the file. +@item +Make sure no employer has any claim to the copyright on the work you are +submitting. If there is any doubt, create a copyright disclaimer and +have your employer sign it. Mail the signed disclaim to the SLIB +maintainer. Contact jaffer@@ai.mit.edu for the address to mail the +disclaimer to. +@end itemize + +@subheading Example: Company Copyright Disclaimer + +This disclaimer should be signed by a vice president or general manager +of the company. If you can't get at them, anyone else authorized to +license out software produced there will do. Here is a sample wording: + +@quotation +@var{employer} Corporation hereby disclaims all copyright +interest in the program @var{program} written by @var{name}. + +@var{employer} Corporation affirms that it has no other intellectual +property interest that would undermine this release, and will do nothing +to undermine it in the future. + +@flushleft +@var{signature and date}, +@var{name}, @var{title}, @var{employer} Corporation +@end flushleft +@end quotation + +@node Manual Conventions, , Copyrights, Overview +@section Manual Conventions + +Things that are labeled as Functions are called for their return values. +Things that are labeled as Procedures are called primarily for their +side effects. + +All examples throughout this text were produced using the @code{scm} +Scheme implementation. + +At the beginning of each section, there is a line that looks something +like + +@code{(require 'feature)}. + +@noindent +This means that, in order to use @code{feature}, you must include the +line @code{(require 'feature)} somewhere in your code prior to the use +of that feature. @code{require} will make sure that the feature is +loaded.@refill + + + + + +@node Data Structures, Macros, Overview, Top +@chapter Data Structures + + + +@menu +* Arrays:: 'array +* Array Mapping:: 'array-for-each +* Association Lists:: 'alist +* Collections:: 'collect +* Dynamic Data Type:: 'dynamic +* Hash Tables:: 'hash-table +* Hashing:: 'hash, 'sierpinski, 'soundex +* Chapter Ordering:: 'chapter-order +* Object:: 'object +* Parameter lists:: 'parameters +* Priority Queues:: 'priority-queue +* Queues:: 'queue +* Records:: 'record +* Base Table:: +* Relational Database:: 'relational-database +* Weight-Balanced Trees:: 'wt-tree +* Structures:: 'struct, 'structure +@end menu + + + + +@node Arrays, Array Mapping, Data Structures, Data Structures +@section Arrays + +@code{(require 'array)} + +@defun array? obj +Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not. +@end defun + +@defun make-array initial-value bound1 bound2 @dots{} +Creates and returns an array that has as many dimensins as there are +@var{bound}s and fills it with @var{initial-value}.@refill +@end defun + +When constructing an array, @var{bound} is either an inclusive range of +indices expressed as a two element list, or an upper bound expressed as +a single integer. So@refill +@lisp +(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2)) +@end lisp + +@defun make-shared-array array mapper bound1 bound2 @dots{} +@code{make-shared-array} can be used to create shared subarrays of other +arrays. The @var{mapper} is a function that translates coordinates in +the new array into coordinates in the old array. A @var{mapper} must be +linear, and its range must stay within the bounds of the old array, but +it can be otherwise arbitrary. A simple example:@refill +@lisp +(define fred (make-array #f 8 8)) +(define freds-diagonal + (make-shared-array fred (lambda (i) (list i i)) 8)) +(array-set! freds-diagonal 'foo 3) +(array-ref fred 3 3) + @result{} FOO +(define freds-center + (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) + 2 2)) +(array-ref freds-center 0 0) + @result{} FOO +@end lisp +@end defun + +@defun array-rank obj +Returns the number of dimensions of @var{obj}. If @var{obj} is not an +array, 0 is returned. +@end defun + +@defun array-shape array +@code{array-shape} returns a list of inclusive bounds. So: +@lisp +(array-shape (make-array 'foo 3 5)) + @result{} ((0 2) (0 4)) +@end lisp +@end defun + +@defun array-dimensions array +@code{array-dimensions} is similar to @code{array-shape} but replaces +elements with a 0 minimum with one greater than the maximum. So: +@lisp +(array-dimensions (make-array 'foo 3 5)) + @result{} (3 5) +@end lisp +@end defun + +@deffn Procedure array-in-bounds? array index1 index2 @dots{} +Returns @code{#t} if its arguments would be acceptable to +@code{array-ref}. +@end deffn + +@defun array-ref array index1 index2 @dots{} +Returns the element at the @code{(@var{index1}, @var{index2})} element +in @var{array}.@refill +@end defun + +@deffn Procedure array-set! array new-value index1 index2 @dots{} +@end deffn + +@defun array-1d-ref array index +@defunx array-2d-ref array index index +@defunx array-3d-ref array index index index +@end defun + +@deffn Procedure array-1d-set! array new-value index +@deffnx Procedure array-2d-set! array new-value index index +@deffnx Procedure array-3d-set! array new-value index index index +@end deffn + +The functions are just fast versions of @code{array-ref} and +@code{array-set!} that take a fixed number of arguments, and perform no +bounds checking.@refill + +If you comment out the bounds checking code, this is about as efficient +as you could ask for without help from the compiler. + +An exercise left to the reader: implement the rest of APL. + + + +@node Array Mapping, Association Lists, Arrays, Data Structures +@section Array Mapping + +@code{(require 'array-for-each)} + +@defun array-map! array0 proc array1 @dots{} +@var{array1}, @dots{} must have the same number of dimensions as +@var{array0} and have a range for each index which includes the range +for the corresponding index in @var{array0}. @var{proc} is applied to +each tuple of elements of @var{array1} @dots{} and the result is stored +as the corresponding element in @var{array0}. The value returned is +unspecified. The order of application is unspecified. +@end defun + +@defun array-for-each @var{proc} @var{array0} @dots{} +@var{proc} is applied to each tuple of elements of @var{array0} @dots{} +in row-major order. The value returned is unspecified. +@end defun + +@defun array-indexes @var{array} +Returns an array of lists of indexes for @var{array} such that, if +@var{li} is a list of indexes for which @var{array} is defined, (equal? +@var{li} (apply array-ref (array-indexes @var{array}) @var{li})). +@end defun + +@defun array-copy! source destination +Copies every element from vector or array @var{source} to the +corresponding element of @var{destination}. @var{destination} must have +the same rank as @var{source}, and be at least as large in each +dimension. The order of copying is unspecified. +@end defun + + +@node Association Lists, Collections, Array Mapping, Data Structures +@section Association Lists + +@code{(require 'alist)} + +Alist functions provide utilities for treating a list of key-value pairs +as an associative database. These functions take an equality predicate, +@var{pred}, as an argument. This predicate should be repeatable, +symmetric, and transitive.@refill + +Alist functions can be used with a secondary index method such as hash +tables for improved performance. + +@defun predicate->asso pred +Returns an @dfn{association function} (like @code{assq}, @code{assv}, or +@code{assoc}) corresponding to @var{pred}. The returned function +returns a key-value pair whose key is @code{pred}-equal to its first +argument or @code{#f} if no key in the alist is @var{pred}-equal to the +first argument.@refill +@end defun + +@defun alist-inquirer pred +Returns a procedure of 2 arguments, @var{alist} and @var{key}, which +returns the value associated with @var{key} in @var{alist} or @code{#f} if +@var{key} does not appear in @var{alist}.@refill +@end defun + +@defun alist-associator pred +Returns a procedure of 3 arguments, @var{alist}, @var{key}, and +@var{value}, which returns an alist with @var{key} and @var{value} +associated. Any previous value associated with @var{key} will be +lost. This returned procedure may or may not have side effects on its +@var{alist} argument. An example of correct usage is:@refill +@lisp +(define put (alist-associator string-ci=?)) +(define alist '()) +(set! alist (put alist "Foo" 9)) +@end lisp +@end defun + +@defun alist-remover pred +Returns a procedure of 2 arguments, @var{alist} and @var{key}, which +returns an alist with an association whose @var{key} is key removed. +This returned procedure may or may not have side effects on its +@var{alist} argument. An example of correct usage is:@refill +@lisp +(define rem (alist-remover string-ci=?)) +(set! alist (rem alist "foo")) +@end lisp +@end defun + +@defun alist-map proc alist +Returns a new association list formed by mapping @var{proc} over the +keys and values of @var{alist}. @var{proc} must be a function of 2 +arguments which returns the new value part. +@end defun + +@defun alist-for-each proc alist +Applies @var{proc} to each pair of keys and values of @var{alist}. +@var{proc} must be a function of 2 arguments. The returned value is +unspecified. +@end defun + + +@node Collections, Dynamic Data Type, Association Lists, Data Structures +@section Collections + +@c Much of the documentation in this section was written by Dave Love +@c (d.love@dl.ac.uk) -- don't blame Ken Dickey for its faults. +@c but we can blame him for not writing it! + +@code{(require 'collect)} + +Routines for managing collections. Collections are aggregate data +structures supporting iteration over their elements, similar to the +Dylan(TM) language, but with a different interface. They have +@dfn{elements} indexed by corresponding @dfn{keys}, although the keys +may be implicit (as with lists).@refill + +New types of collections may be defined as YASOS objects (@xref{Yasos}). +They must support the following operations: +@itemize @bullet +@item +@code{(collection? @var{self})} (always returns @code{#t}); + +@item +@code{(size @var{self})} returns the number of elements in the collection; + +@item +@code{(print @var{self} @var{port})} is a specialized print operation +for the collection which prints a suitable representation on the given +@var{port} or returns it as a string if @var{port} is @code{#t};@refill + +@item +@code{(gen-elts @var{self})} returns a thunk which on successive +invocations yields elements of @var{self} in order or gives an error if +it is invoked more than @code{(size @var{self})} times;@refill + +@item +@code{(gen-keys @var{self})} is like @code{gen-elts}, but yields the +collection's keys in order. + +@end itemize +They might support specialized @code{for-each-key} and +@code{for-each-elt} operations.@refill + +@defun collection? obj +A predicate, true initially of lists, vectors and strings. New sorts of +collections must answer @code{#t} to @code{collection?}.@refill +@end defun + +@deffn Procedure map-elts proc . collections +@deffnx Procedure do-elts proc . collections +@var{proc} is a procedure taking as many arguments as there are +@var{collections} (at least one). The @var{collections} are iterated +over in their natural order and @var{proc} is applied to the elements +yielded by each iteration in turn. The order in which the arguments are +supplied corresponds to te order in which the @var{collections} appear. +@code{do-elts} is used when only side-effects of @var{proc} are of +interest and its return value is unspecified. @code{map-elts} returns a +collection (actually a vector) of the results of the applications of +@var{proc}.@refill + +Example: +@lisp +(map-elts + (list 1 2 3) (vector 1 2 3)) + @result{} #(2 4 6) +@end lisp +@end deffn + +@deffn Procedure map-keys proc . collections +@deffnx Procedure do-keys proc . collections +These are analogous to @code{map-elts} and @code{do-elts}, but each +iteration is over the @var{collections}' @emph{keys} rather than their +elements.@refill + +Example: +@lisp +(map-keys + (list 1 2 3) (vector 1 2 3)) + @result{} #(0 2 4) +@end lisp +@end deffn + +@deffn Procedure for-each-key collection proc +@deffnx Procedure for-each-elt collection proc +These are like @code{do-keys} and @code{do-elts} but only for a single +collection; they are potentially more efficient. +@end deffn + +@defun reduce proc seed . collections +A generalization of the list-based @code{comlist:reduce-init} +(@xref{Lists as sequences}) to collections which will shadow the +list-based version if @code{(require 'collect)} follows @code{(require +'common-list-functions)} (@xref{Common List Functions}).@refill + +Examples: +@lisp +(reduce + 0 (vector 1 2 3)) + @result{} 6 +(reduce union '() '((a b c) (b c d) (d a))) + @result{} (c b d a). +@end lisp +@end defun + +@defun any? pred . collections +A generalization of the list-based @code{some} (@xref{Lists as +sequences}) to collections.@refill + +Example: +@lisp +(any? odd? (list 2 3 4 5)) + @result{} #t +@end lisp +@end defun + +@defun every? pred . collections +A generalization of the list-based @code{every} (@xref{Lists as +sequences}) to collections.@refill + +Example: +@lisp +(every? collection? '((1 2) #(1 2))) + @result{} #t +@end lisp +@end defun + +@defun empty? collection +Returns @code{#t} iff there are no elements in @var{collection}. + +@code{(empty? @var{collection}) @equiv{} (zero? (size @var{collection}))} +@end defun + +@defun size collection +Returns the number of elements in @var{collection}. +@end defun + +@defun Setter list-ref +See @xref{Setters} for a definition of @dfn{setter}. N.B. +@code{(setter list-ref)} doesn't work properly for element 0 of a +list.@refill +@end defun + +Here is a sample collection: @code{simple-table} which is also a +@code{table}.@refill +@lisp +(define-predicate TABLE?) +(define-operation (LOOKUP table key failure-object)) +(define-operation (ASSOCIATE! table key value)) ;; returns key +(define-operation (REMOVE! table key)) ;; returns value + +(define (MAKE-SIMPLE-TABLE) + (let ( (table (list)) ) + (object + ;; table behaviors + ((TABLE? self) #t) + ((SIZE self) (size table)) + ((PRINT self port) (format port "#")) + ((LOOKUP self key failure-object) + (cond + ((assq key table) => cdr) + (else failure-object) + )) + ((ASSOCIATE! self key value) + (cond + ((assq key table) + => (lambda (bucket) (set-cdr! bucket value) key)) + (else + (set! table (cons (cons key value) table)) + key) + )) + ((REMOVE! self key);; returns old value + (cond + ((null? table) (slib:error "TABLE:REMOVE! Key not found: " key)) + ((eq? key (caar table)) + (let ( (value (cdar table)) ) + (set! table (cdr table)) + value) + ) + (else + (let loop ( (last table) (this (cdr table)) ) + (cond + ((null? this) + (slib:error "TABLE:REMOVE! Key not found: " key)) + ((eq? key (caar this)) + (let ( (value (cdar this)) ) + (set-cdr! last (cdr this)) + value) + ) + (else + (loop (cdr last) (cdr this))) + ) ) ) + )) + ;; collection behaviors + ((COLLECTION? self) #t) + ((GEN-KEYS self) (collect:list-gen-elts (map car table))) + ((GEN-ELTS self) (collect:list-gen-elts (map cdr table))) + ((FOR-EACH-KEY self proc) + (for-each (lambda (bucket) (proc (car bucket))) table) + ) + ((FOR-EACH-ELT self proc) + (for-each (lambda (bucket) (proc (cdr bucket))) table) + ) + ) ) ) +@end lisp + + + + + +@node Dynamic Data Type, Hash Tables, Collections, Data Structures +@section Dynamic Data Type + +@code{(require 'dynamic)} + +@defun make-dynamic obj +Create and returns a new @dfn{dynamic} whose global value is @var{obj}. +@end defun + +@defun dynamic? obj +Returns true if and only if @var{obj} is a dynamic. No object +satisfying @code{dynamic?} satisfies any of the other standard type +predicates.@refill +@end defun + +@defun dynamic-ref dyn +Return the value of the given dynamic in the current dynamic +environment. +@end defun + +@deffn Procedure dynamic-set! dyn obj +Change the value of the given dynamic to @var{obj} in the current +dynamic environment. The returned value is unspecified.@refill +@end deffn + +@defun call-with-dynamic-binding dyn obj thunk +Invoke and return the value of the given thunk in a new, nested dynamic +environment in which the given dynamic has been bound to a new location +whose initial contents are the value @var{obj}. This dynamic +environment has precisely the same extent as the invocation of the thunk +and is thus captured by continuations created within that invocation and +re-established by those continuations when they are invoked.@refill +@end defun + +The @code{dynamic-bind} macro is not implemented. + + + + +@node Hash Tables, Hashing, Dynamic Data Type, Data Structures +@section Hash Tables + +@code{(require 'hash-table)} + +@defun predicate->hash pred +Returns a hash function (like @code{hashq}, @code{hashv}, or +@code{hash}) corresponding to the equality predicate @var{pred}. +@var{pred} should be @code{eq?}, @code{eqv?}, @code{equal?}, @code{=}, +@code{char=?}, @code{char-ci=?}, @code{string=?}, or +@code{string-ci=?}.@refill +@end defun + +A hash table is a vector of association lists. + +@defun make-hash-table k +Returns a vector of @var{k} empty (association) lists. +@end defun + +Hash table functions provide utilities for an associative database. +These functions take an equality predicate, @var{pred}, as an argument. +@var{pred} should be @code{eq?}, @code{eqv?}, @code{equal?}, @code{=}, +@code{char=?}, @code{char-ci=?}, @code{string=?}, or +@code{string-ci=?}.@refill + +@defun predicate->hash-asso pred +Returns a hash association function of 2 arguments, @var{key} and +@var{hashtab}, corresponding to @var{pred}. The returned function +returns a key-value pair whose key is @var{pred}-equal to its first +argument or @code{#f} if no key in @var{hashtab} is @var{pred}-equal to +the first argument.@refill +@end defun + +@defun hash-inquirer pred +Returns a procedure of 3 arguments, @code{hashtab} and @code{key}, which +returns the value associated with @code{key} in @code{hashtab} or +@code{#f} if key does not appear in @code{hashtab}.@refill +@end defun + +@defun hash-associator pred +Returns a procedure of 3 arguments, @var{hashtab}, @var{key}, and +@var{value}, which modifies @var{hashtab} so that @var{key} and +@var{value} associated. Any previous value associated with @var{key} +will be lost.@refill +@end defun + +@defun hash-remover pred +Returns a procedure of 2 arguments, @var{hashtab} and @var{key}, which +modifies @var{hashtab} so that the association whose key is @var{key} is +removed.@refill +@end defun + +@defun hash-map proc hash-table +Returns a new hash table formed by mapping @var{proc} over the +keys and values of @var{hash-table}. @var{proc} must be a function of 2 +arguments which returns the new value part. +@end defun + +@defun hash-for-each proc hash-table +Applies @var{proc} to each pair of keys and values of @var{hash-table}. +@var{proc} must be a function of 2 arguments. The returned value is +unspecified. +@end defun + + + + + +@node Hashing, Chapter Ordering, Hash Tables, Data Structures +@section Hashing + +@code{(require 'hash)} + +These hashing functions are for use in quickly classifying objects. +Hash tables use these functions. + +@defun hashq obj k +@defunx hashv obj k +@defunx hash obj k +Returns an exact non-negative integer less than @var{k}. For each +non-negative integer less than @var{k} there are arguments @var{obj} for +which the hashing functions applied to @var{obj} and @var{k} returns +that integer.@refill + +For @code{hashq}, @code{(eq? obj1 obj2)} implies @code{(= (hashq obj1 k) +(hashq obj2))}.@refill + +For @code{hashv}, @code{(eqv? obj1 obj2)} implies @code{(= (hashv obj1 k) +(hashv obj2))}.@refill + +For @code{hash}, @code{(equal? obj1 obj2)} implies @code{(= (hash obj1 k) +(hash obj2))}.@refill + +@code{hash}, @code{hashv}, and @code{hashq} return in time bounded by a +constant. Notice that items having the same @code{hash} implies the +items have the same @code{hashv} implies the items have the same +@code{hashq}.@refill +@end defun + + +@code{(require 'sierpinski)} + +@defun make-sierpinski-indexer max-coordinate +Returns a procedure (eg hash-function) of 2 numeric arguments which +preserves @emph{nearness} in its mapping from NxN to N. + +@var{max-coordinate} is the maximum coordinate (a positive integer) of a +population of points. The returned procedures is a function that takes +the x and y coordinates of a point, (non-negative integers) and returns +an integer corresponding to the relative position of that point along a +Sierpinski curve. (You can think of this as computing a (pseudo-) +inverse of the Sierpinski spacefilling curve.) + +Example use: Make an indexer (hash-function) for integer points lying in +square of integer grid points [0,99]x[0,99]: +@example +(define space-key (make-sierpinski-indexer 100)) +@end example +Now let's compute the index of some points: +@example +(space-key 24 78) @result{} 9206 +(space-key 23 80) @result{} 9172 +@end example + +Note that locations (24, 78) and (23, 80) are near in index and +therefore, because the Sierpinski spacefilling curve is continuous, we +know they must also be near in the plane. Nearness in the plane does +not, however, necessarily correspond to nearness in index, although it +@emph{tends} to be so. + +Example applications: +@table @asis + +@item +Sort points by Sierpinski index to get heuristic solution to +@emph{travelling salesman problem}. For details of performance, +see L. Platzman and J. Bartholdi, "Spacefilling curves and the +Euclidean travelling salesman problem", JACM 36(4):719--737 +(October 1989) and references therein. + +@item +Use Sierpinski index as key by which to store 2-dimensional data +in a 1-dimensional data structure (such as a table). Then +locations that are near each other in 2-d space will tend to +be near each other in 1-d data structure; and locations that +are near in 1-d data structure will be near in 2-d space. This +can significantly speed retrieval from secondary storage because +contiguous regions in the plane will tend to correspond to +contiguous regions in secondary storage. (This is a standard +technique for managing CAD/CAM or geographic data.) + +@end table +@end defun + + + +@code{(require 'soundex)} + +@defun soundex name +Computes the @emph{soundex} hash of @var{name}. Returns a string of an +initial letter and up to three digits between 0 and 6. Soundex +supposedly has the property that names that sound similar in normal +English pronunciation tend to map to the same key. + +Soundex was a classic algorithm used for manual filing of personal +records before the advent of computers. It performs adequately for +English names but has trouble with other nationalities. + +See Knuth, Vol. 3 @cite{Sorting and searching}, pp 391--2 + +To manage unusual inputs, @code{soundex} omits all non-alphabetic +characters. Consequently, in this implementation: + +@example +(soundex ) @result{} "" +(soundex "") @result{} "" +@end example + +Examples from Knuth: + +@example +(map soundex '("Euler" "Gauss" "Hilbert" "Knuth" + "Lloyd" "Lukasiewicz")) + @result{} ("E460" "G200" "H416" "K530" "L300" "L222") + +(map soundex '("Ellery" "Ghosh" "Heilbronn" "Kant" + "Ladd" "Lissajous")) + @result{} ("E460" "G200" "H416" "K530" "L300" "L222") +@end example + +Some cases in which the algorithm fails (Knuth): + +@example +(map soundex '("Rogers" "Rodgers")) @result{} ("R262" "R326") + +(map soundex '("Sinclair" "St. Clair")) @result{} ("S524" "S324") + +(map soundex '("Tchebysheff" "Chebyshev")) @result{} ("T212" "C121") +@end example +@end defun + +@node Chapter Ordering, Object, Hashing, Data Structures +@section Chapter Ordering + +@code{(require 'chapter-order)} + +The @samp{chap:} functions deal with strings which are ordered like +chapter numbers (or letters) in a book. Each section of the string +consists of consecutive numeric or consecutive aphabetic characters of +like case. + +@defun chap:string? string1 string2 +@defunx chap:string<=? string1 string2 +@defunx chap:string>=? string1 string2 +Implement the corresponding chapter-order predicates. +@end defun + +@defun chap:next-string string +Returns the next string in the @emph{chapter order}. If @var{string} +has no alphabetic or numeric characters, +@code{(string-append @var{string} "0")} is returnd. The argument to +chap:next-string will always be @code{chap:string::( ) +@end lisp +Generic-methods +@lisp + ::value @result{} ::value + ::set-value! @result{} ::set-value! + ::describe @result{} ::describe + ::help + ::invert + ::inverter? +@end lisp + +@subsubsection Number Documention +Inheritance +@lisp + ::() +@end lisp +Slots +@lisp + :: +@end lisp +Generic Methods +@lisp + ::value + ::set-value! +@end lisp + +@subsubsection Inverter code +@example +(require 'object) + +(define value (make-generic-method (lambda (val) val))) +(define set-value! (make-generic-method)) +(define invert (make-generic-method + (lambda (val) + (if (number? val) + (/ 1 val) + (error "Method not supported:" val))))) +(define noop (make-generic-method)) +(define inverter? (make-generic-predicate)) +(define describe (make-generic-method)) +(define help (make-generic-method)) + +(define (make-number x) + (define self (make-object)) + (make-method! self value (lambda (this) x)) + (make-method! self set-value! + (lambda (this new-value) (set! x new-value))) + self) + +(define (make-description str) + (define self (make-object)) + (make-method! self describe (lambda (this) str)) + (make-method! self help (lambda (this) "Help not available")) + self) + +(define (make-inverter) + (define self (make-object + (make-number 1) + (make-description "A number which can be inverted"))) + (define (get-method self value)) + (make-method! self invert (lambda (self) (/ 1 ( self)))) + (make-predicate! self inverter?) + (unmake-method! self help) + (make-method! self help + (lambda (self) + (display "Inverter Methods:") (newline) + (display " (value inverter) ==> n") (newline))) + self) + +;;;; Try it out + +(define invert! (make-generic-method)) + +(define x (make-inverter)) + +(make-method! x invert! (lambda () (set-value! x (/ 1 (value x))))) + +(value x) @result{} 1 +(set-value! x 33) @result{} undefined +(invert! x) @result{} undefined +(value x) @result{} 1/33 + +(unmake-method! x invert!) @result{} undefined + +(invert! x) @error{} ERROR: Method not supported: x +@end example + +@node Parameter lists, Priority Queues, Object, Data Structures +@section Parameter lists + +@code{(require 'parameters)} + +@noindent +Arguments to procedures in scheme are distinguished from each other by +their position in the procedure call. This can be confusing when a +procedure takes many arguments, many of which are not often used. + +@noindent +A @dfn{parameter-list} is a way of passing named information to a +procedure. Procedures are also defined to set unused parameters to +default values, check parameters, and combine parameter lists. + +@noindent +A @var{parameter} has the form @code{(@r{parameter-name} @r{value1} +@dots{})}. This format allows for more than one value per +parameter-name. + +@noindent +A @var{parameter-list} is a list of @var{parameter}s, each with a +different @var{parameter-name}. + +@deffn Function make-parameter-list parameter-names +Returns an empty parameter-list with slots for @var{parameter-names}. +@end deffn + +@deffn Function parameter-list-ref parameter-list parameter-name +@var{parameter-name} must name a valid slot of @var{parameter-list}. +@code{parameter-list-ref} returns the value of parameter +@var{parameter-name} of @var{parameter-list}. +@end deffn + +@deffn Procedure adjoin-parameters! parameter-list parameter1 @dots{} +Returns @var{parameter-list} with @var{parameter1} @dots{} merged in. +@end deffn + +@deffn Procedure parameter-list-expand expanders parameter-list +@var{expanders} is a list of procedures whose order matches the order of +the @var{parameter-name}s in the call to @code{make-parameter-list} +which created @var{parameter-list}. For each non-false element of +@var{expanders} that procedure is mapped over the corresponding +parameter value and the returned parameter lists are merged into +@var{parameter-list}. + +This process is repeated until @var{parameter-list} stops growing. The +value returned from @code{parameter-list-expand} is unspecified. +@end deffn + +@deffn Function fill-empty-parameters defaults parameter-list +@var{defaults} is a list of lists whose order matches the order of the +@var{parameter-name}s in the call to @code{make-parameter-list} which +created @var{parameter-list}. @code{fill-empty-parameters} returns a +new parameter-list with each empty parameter filled with the +corresponding @var{default}. +@end deffn + +@deffn Function check-parameters checks parameter-list +@var{checks} is a list of procedures whose order matches the order of +the @var{parameter-name}s in the call to @code{make-parameter-list} +which created @var{parameter-list}. + +@code{check-parameters} returns @var{parameter-list} if each @var{check} +of the corresponding @var{parameter-list} returns non-false. If some +@var{check} returns @code{#f} an error is signaled. +@end deffn + +@noindent +In the following procedures @var{arities} is a list of symbols. The +elements of @code{arities} can be: + +@table @code +@item single +Requires a single parameter. +@item optional +A single parameter or no parameter is acceptable. +@item boolean +A single boolean parameter or zero parameters is acceptable. +@item nary +Any number of parameters are acceptable. +@item nary1 +One or more of parameters are acceptable. +@end table + +@deffn Function parameter-list->arglist positions arities types parameter-list +Returns @var{parameter-list} converted to an argument list. Parameters +of @var{arity} type @code{single} and @code{boolean} are converted to +the single value associated with them. The other @var{arity} types are +converted to lists of the value(s) of type @var{types}. + +@var{positions} is a list of positive integers whose order matches the +order of the @var{parameter-name}s in the call to +@code{make-parameter-list} which created @var{parameter-list}. The +integers specify in which argument position the corresponding parameter +should appear. +@end deffn + +@deffn Function getopt->parameter-list argc argv optnames arities types aliases +Returns @var{argv} converted to a parameter-list. @var{optnames} are +the parameter-names. @var{aliases} is a list of lists of strings and +elements of @var{optnames}. Each of these strings which have length of +1 will be treated as a single @key{-} option by @code{getopt}. Longer +strings will be treated as long-named options (@pxref{Getopt, getopt--}). +@end deffn + +@deffn Function getopt->arglist argc argv optnames positions arities types defaults checks aliases +Like @code{getopt->parameter-list}, but converts @var{argv} to an +argument-list as specified by @var{optnames}, @var{positions}, +@var{arities}, @var{types}, @var{defaults}, @var{checks}, and +@var{aliases}. +@end deffn + +These @code{getopt} functions can be used with SLIB relational +databases. For an example, @xref{Database Utilities, +make-command-server}. + +@node Priority Queues, Queues, Parameter lists, Data Structures +@section Priority Queues + +@code{(require 'priority-queue)} + +@defun make-heap predlist key-dimension types +Returns a procedure which accepts objects produced by application of the +result of @code{(make-list-keyifier @var{key-dimension} @var{types})}. +This procedure returns a list of @var{key}s which are elementwise +@code{equal?} to the list which was passed to create @var{combined-key}. +@end defun + +@noindent +In the following functions, the @var{key} argument can always be assumed +to be the value returned by a call to a @emph{keyify} routine. + +@defun for-each-key handle procedure +Calls @var{procedure} once with each @var{key} in the table opened in +@var{handle} in an unspecified order. An unspecified value is returned. +@end defun + +@defun map-key handle procedure +Returns a list of the values returned by calling @var{procedure} once +with each @var{key} in the table opened in @var{handle} in an +unspecified order. +@end defun + +@defun ordered-for-each-key handle procedure +Calls @var{procedure} once with each @var{key} in the table opened in +@var{handle} in the natural order for the types of the primary key +fields of that table. An unspecified value is returned. +@end defun + +@defun present? handle key +Returns a non-@code{#f} value if there is a row associated with +@var{key} in the table opened in @var{handle} and @code{#f} otherwise. +@end defun + +@defun delete handle key +Removes the row associated with @var{key} from the table opened in +@var{handle}. An unspecified value is returned. +@end defun + +@defun make-getter key-dimension types +Returns a procedure which takes arguments @var{handle} and @var{key}. +This procedure returns a list of the non-primary values of the relation +(in the base table opened in @var{handle}) whose primary key is +@var{key} if it exists, and @code{#f} otherwise. +@end defun + +@defun make-putter key-dimension types +Returns a procedure which takes arguments @var{handle} and @var{key} and +@var{value-list}. This procedure associates the primary key @var{key} +with the values in @var{value-list} (in the base table opened in +@var{handle}) and returns an unspecified value. +@end defun + +@defun supported-type? symbol +Returns @code{#t} if @var{symbol} names a type allowed as a column value +by the implementation, and @code{#f} otherwise. At a minimum, an +implementation must support the types @code{integer}, @code{symbol}, +@code{string}, @code{boolean}, and @code{base-id}. +@end defun + +@defun supported-key-type? symbol +Returns @code{#t} if @var{symbol} names a type allowed as a key value by +the implementation, and @code{#f} otherwise. At a minimum, an +implementation must support the types @code{integer}, and @code{symbol}. +@end defun + +@table @code +@item integer +Scheme exact integer. +@item symbol +Scheme symbol. +@item boolean +@code{#t} or @code{#f}. +@item base-id +Objects suitable for passing as the @var{base-id} parameter to +@code{open-table}. The value of @var{catalog-id} must be an acceptable +@code{base-id}. +@end table + +@node Relational Database, Weight-Balanced Trees, Base Table, Data Structures +@section Relational Database + +@code{(require 'relational-database)} + +This package implements a database system inspired by the Relational +Model (@cite{E. F. Codd, A Relational Model of Data for Large Shared +Data Banks}). An SLIB relational database implementation can be created +from any @ref{Base Table} implementation. + +@menu +* Motivations:: Database Manifesto +* Creating and Opening Relational Databases:: +* Relational Database Operations:: +* Table Operations:: +* Catalog Representation:: +* Unresolved Issues:: +* Database Utilities:: 'database-utilities +@end menu + +@node Motivations, Creating and Opening Relational Databases, Relational Database, Relational Database +@subsection Motivations + +Most nontrivial programs contain databases: Makefiles, configure +scripts, file backup, calendars, editors, source revision control, CAD +systems, display managers, menu GUIs, games, parsers, debuggers, +profilers, and even error reporting are all rife with databases. Coding +databases is such a common activity in programming that many may not be +aware of how often they do it. + +A database often starts as a dispatch in a program. The author, perhaps +because of the need to make the dispatch configurable, the need for +correlating dispatch in other routines, or because of changes or growth, +devises a data structure to contain the information, a routine for +interpreting that data structure, and perhaps routines for augmenting +and modifying the stored data. The dispatch must be converted into this +form and tested. + +The programmer may need to devise an interactive program for enabling +easy examination and modification of the information contained in this +database. Often, in an attempt to foster modularity and avoid delays in +release, intermediate file formats for the database information are +devised. It often turns out that users prefer modifying these +intermediate files with a text editor to using the interactive program +in order to do operations (such as global changes) not forseen by the +program's author. + +In order to address this need, the concientous software engineer may +even provide a scripting language to allow users to make repetitive +database changes. Users will grumble that they need to read a large +manual and learn yet another programming language (even if it +@emph{almost} has language "xyz" syntax) in order to do simple +configuration. + +All of these facilities need to be designed, coded, debugged, +documented, and supported; often causing what was very simple in concept +to become a major developement project. + +This view of databases just outlined is somewhat the reverse of the view +of the originators of the @dfn{Relational Model} of database +abstraction. The relational model was devised to unify and allow +interoperation of large multi-user databases running on diverse +platforms. A fairly general purpose "Comprehensive Language" for +database manipulations is mandated (but not specified) as part of the +relational model for databases. + +One aspect of the Relational Model of some importance is that the +"Comprehensive Language" must be expressible in some form which can be +stored in the database. This frees the programmer from having to make +programs data-driven in order to use a database. + +This package includes as one of its basic supported types Scheme +@dfn{expression}s. This type allows expressions as defined by the +Scheme standards to be stored in the database. Using @code{slib:eval} +retrieved expressions can be evaluated (in the top-level environment). +Scheme's @code{lambda} facilitates closure of environments, modularity, +etc. so that procedures (which could not be stored directly most +databases) can still be effectively retrieved. Since @code{slib:eval} +evaluates expressions in the top-level environment, built-in and user +defined procedures can be easily accessed by name. + +This package's purpose is to standardize (through a common interface) +database creation and usage in Scheme programs. The relational model's +provision for inclusion of language expressions as data as well as the +description (in tables, of course) of all of its tables assures that +relational databases are powerful enough to assume the roles currently +played by thousands of ad-hoc routines and data formats. + +@noindent +Such standardization to a relational-like model brings many benefits: + +@itemize @bullet +@item +Tables, fields, domains, and types can be dealt with by name in +programs. +@item +The underlying database implementation can be changed (for +performance or other reasons) by changing a single line of code. +@item +The formats of tables can be easily extended or changed without +altering code. +@item +Consistency checks are specified as part of the table descriptions. +Changes in checks need only occur in one place. +@item +All the configuration information which the developer wishes to group +together is easily grouped, without needing to change programs aware of +only some of these tables. +@item +Generalized report generators, interactive entry programs, and other +database utilities can be part of a shared library. The burden of +adding configurability to a program is greatly reduced. +@item +Scheme is the "comprehensive language" for these databases. Scripting +for configuration no longer needs to be in a separate language with +additional documentation. +@item +Scheme's latent types mesh well with the strict typing and logical +requirements of the relational model. +@item +Portable formats allow easy interchange of data. The included table +descriptions help prevent misinterpretation of format. +@end itemize + +@node Creating and Opening Relational Databases, Relational Database Operations, Motivations, Relational Database +@subsection Creating and Opening Relational Databases + +@defun make-relational-system base-table-implementation + +Returns a procedure implementing a relational database using the +@var{base-table-implementation}. + +All of the operations of a base table implementation are accessed +through a procedure defined by @code{require}ing that implementation. +Similarly, all of the operations of the relational database +implementation are accessed through the procedure returned by +@code{make-relational-system}. For instance, a new relational database +could be created from the procedure returned by +@code{make-relational-system} by: + +@example +(require 'alist-table) +(define relational-alist-system + (make-relational-system alist-table)) +(define create-alist-database + (relational-alist-system 'create-database)) +(define my-database + (create-alist-database "mydata.db")) +@end example +@end defun + +@noindent +What follows are the descriptions of the methods available from +relational system returned by a call to @code{make-relational-system}. + +@defun create-database filename + +Returns an open, nearly empty relational database associated with +@var{filename}. The only tables defined are the system catalog and +domain table. Calling the @code{close-database} method on this database +and possibly other operations will cause @var{filename} to be written +to. If @var{filename} is @code{#f} a temporary, non-disk based database +will be created if such can be supported by the underlying base table +implelentation. If the database cannot be created as specified +@code{#f} is returned. For the fields and layout of descriptor tables, +@xref{Catalog Representation} +@end defun + +@defun open-database filename mutable? + +Returns an open relational database associated with @var{filename}. If +@var{mutable?} is @code{#t}, this database will have methods capable of +effecting change to the database. If @var{mutable?} is @code{#f}, only +methods for inquiring the database will be available. Calling the +@code{close-database} (and possibly other) method on a @var{mutable?} +database will cause @var{filename} to be written to. If the database +cannot be opened as specified @code{#f} is returned. +@end defun + +@node Relational Database Operations, Table Operations, Creating and Opening Relational Databases, Relational Database +@subsection Relational Database Operations + +@noindent +These are the descriptions of the methods available from an open +relational database. A method is retrieved from a database by calling +the database with the symbol name of the operation. For example: + +@example +(define my-database + (create-alist-database "mydata.db")) +(define telephone-table-desc + ((my-database 'create-table) 'telephone-table-desc)) +@end example + +@defun close-database +Causes the relational database to be written to its associated file (if +any). If the write is successful, subsequent operations to this +database will signal an error. If the operations completed +successfully, @code{#t} is returned. Otherwise, @code{#f} is returned. +@end defun + +@defun write-database filename +Causes the relational database to be written to @var{filename}. If the +write is successful, also causes the database to henceforth be +associated with @var{filename}. Calling the @code{close-database} (and +possibly other) method on this database will cause @var{filename} to be +written to. If @var{filename} is @code{#f} this database will be +changed to a temporary, non-disk based database if such can be supported +by the underlying base table implelentation. If the operations +completed successfully, @code{#t} is returned. Otherwise, @code{#f} is +returned. +@end defun + +@defun table-exists? table-name +Returns @code{#t} if @var{table-name} exists in the system catalog, +otherwise returns @code{#f}. +@end defun + +@defun open-table table-name mutable? +Returns a @dfn{methods} procedure for an existing relational table in +this database if it exists and can be opened in the mode indicated by +@var{mutable?}, otherwise returns @code{#f}. +@end defun + +@noindent +These methods will be present only in databases which are +@var{mutable?}. + +@defun delete-table table-name +Removes and returns the @var{table-name} row from the system catalog if +the table or view associated with @var{table-name} gets removed from the +database, and @code{#f} otherwise. +@end defun + +@defun create-table table-desc-name +Returns a methods procedure for a new (open) relational table for +describing the columns of a new base table in this database, otherwise +returns @code{#f}. For the fields and layout of descriptor tables, +@xref{Catalog Representation}. + +@defunx create-table table-name table-desc-name +Returns a methods procedure for a new (open) relational table with +columns as described by @var{table-desc-name}, otherwise returns +@code{#f}. +@end defun + +@defun create-view ?? +@defunx project-table ?? +@defunx restrict-table ?? +@defunx cart-prod-tables ?? +Not yet implemented. +@end defun + +@node Table Operations, Catalog Representation, Relational Database Operations, Relational Database +@subsection Table Operations + +@noindent +These are the descriptions of the methods available from an open +relational table. A method is retrieved from a table by calling +the table with the symbol name of the operation. For example: + +@example +@group +(define telephone-table-desc + ((my-database 'create-table) 'telephone-table-desc)) +(require 'common-list-functions) +(define ndrp (telephone-table-desc 'row:insert)) +(ndrp '(1 #t name #f string)) +(ndrp '(2 #f telephone + (lambda (d) + (and (string? d) (> (string-length d) 2) + (every + (lambda (c) + (memv c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + #\+ #\( #\ #\) #\-))) + (string->list d)))) + string)) +@end group +@end example + +@noindent +Operations on a single column of a table are retrieved by giving the +column name as the second argument to the methods procedure. For +example: + +@example +(define column-ids ((telephone-table-desc 'get* 'column-number))) +@end example + +@noindent +Some operations described below require primary key arguments. Primary +keys arguments are denoted @var{key1} @var{key2} @dots{}. It is an +error to call an operation for a table which takes primary key arguments +with the wrong number of primary keys for that table. + +@noindent +The term @dfn{row} used below refers to a Scheme list of values (one for +each column) in the order specified in the descriptor (table) for this +table. Missing values appear as @code{#f}. Primary keys may not +be missing. + +@defun get key1 key2 @dots{} +Returns the value for the specified column of the row associated with +primary keys @var{key1}, @var{key2} @dots{} if it exists, or @code{#f} +otherwise. + +@defunx get* +Returns a list of the values for the specified column for all rows in +this table. + +@defunx row:retrieve key1 key2 @dots{} +Returns the row associated with primary keys @var{key1}, @var{key2} +@dots{} if it exists, or @code{#f} otherwise. + +@defunx row:retrieve* +Returns a list of all rows in this table. +@end defun + +@defun row:remove key1 key2 @dots{} +Removes and returns the row associated with primary keys @var{key1}, +@var{key2} @dots{} if it exists, or @code{#f} otherwise. + +@defunx row:remove* +Removes and returns a list of all rows in this table. +@end defun + +@defun row:delete key1 key2 @dots{} +Deletes the row associated with primary keys @var{key1}, @var{key2} +@dots{} if it exists. The value returned is unspecified. + +@defunx row:delete* +Deletes all rows in this table. The value returned is unspecified. The +descriptor table and catalog entry for this table are not affected. +@end defun + +@defun row:update row +Adds the row, @var{row}, to this table. If a row for the primary key(s) +specified by @var{row} already exists in this table, it will be +overwritten. The value returned is unspecified. + +@defunx row:update* rows +Adds each row in the list @var{rows}, to this table. If a row for the +primary key specified by an element of @var{rows} already exists in this +table, it will be overwritten. The value returned is unspecified. +@end defun + +@defun row:insert row +Adds the row @var{row} to this table. If a row for the primary key(s) +specified by @var{row} already exists in this table an error is +signaled. The value returned is unspecified. + +@defunx row:insert* rows +Adds each row in the list @var{rows}, to this table. If a row for the +primary key specified by an element of @var{rows} already exists in this +table, an error is signaled. The value returned is unspecified. +@end defun + +@defun for-each-row proc +Calls @var{proc} with each @var{row} in this table in the natural +ordering for the primary key types. @emph{Real} relational programmers +would use some least-upper-bound join for every row to get them in +order; But we don't have joins yet. +@end defun + +@defun close-table +Subsequent operations to this table will signal an error. +@end defun + +@defvr Constant column-names +@defvrx Constant column-foreigns +@defvrx Constant column-domains +@defvrx Constant column-types +Return a list of the column names, foreign-key table names, domain +names, or type names respectively for this table. These 4 methods are +different from the others in that the list is returned, rather than a +procedure to obtain the list. + +@defvrx Constant primary-limit +Returns the number of primary keys fields in the relations in this +table. +@end defvr + +@node Catalog Representation, Unresolved Issues, Table Operations, Relational Database +@subsection Catalog Representation + +@noindent +Each database (in an implementation) has a @dfn{system catalog} which +describes all the user accessible tables in that database (including +itself). + +@noindent +The system catalog base table has the following fields. @code{PRI} +indicates a primary key for that table. + +@example +@group +PRI table-name + column-limit the highest column number + coltab-name descriptor table name + bastab-id data base table identifier + user-integrity-rule + view-procedure A scheme thunk which, when called, + produces a handle for the view. coltab + and bastab are specified if and only if + view-procedure is not. +@end group +@end example + +@noindent +Descriptors for base tables (not views) are tables (pointed to by +system catalog). Descriptor (base) tables have the fields: + +@example +@group +PRI column-number sequential integers from 1 + primary-key? boolean TRUE for primary key components + column-name + column-integrity-rule + domain-name +@end group +@end example + +@noindent +A @dfn{primary key} is any column marked as @code{primary-key?} in the +corresponding descriptor table. All the @code{primary-key?} columns +must have lower column numbers than any non-@code{primary-key?} columns. +Every table must have at least one primary key. Primary keys must be +sufficient to distinguish all rows from each other in the table. All of +the system defined tables have a single primary key. + +@noindent +This package currently supports tables having from 1 to 4 primary keys +if there are non-primary columns, and any (natural) number if @emph{all} +columns are primary keys. If you need more than 4 primary keys, I would +like to hear what you are doing! + +@noindent +A @dfn{domain} is a category describing the allowable values to occur in +a column. It is described by a (base) table with the fields: + +@example +@group +PRI domain-name + foreign-table + domain-integrity-rule + type-id + type-param +@end group +@end example + +@noindent +The @dfn{type-id} field value is a symbol. This symbol may be used by +the underlying base table implementation in storing that field. + +@noindent +If the @code{foreign-table} field is non-@code{#f} then that field names +a table from the catalog. The values for that domain must match a +primary key of the table referenced by the @var{type-param} (or +@code{#f}, if allowed). This package currently does not support +composite foreign-keys. + +@noindent +The types for which support is planned are: +@example +@group + atom + symbol + string [] + number [] + money + date-time + boolean + + foreign-key + expression + virtual +@end group +@end example + +@node Unresolved Issues, Database Utilities, Catalog Representation, Relational Database +@subsection Unresolved Issues + +Although @file{rdms.scm} is not large I found it very difficult to write +(six rewrites). I am not aware of any other examples of a generalized +relational system (although there is little new in CS). I left out +several aspects of the Relational model in order to simplify the job. +The major features lacking (which might be addressed portably) are +views, transaction boundaries, and protection. + +Protection needs a model for specifying priveledges. Given how +operations are accessed from handles it should not be difficult to +restrict table accesses to those allowed for that user. + +The system catalog has a field called @code{view-procedure}. This +should allow a purely functional implementation of views. This will +work but is unsatisfying for views resulting from a @dfn{select}ion +(subset of rows); for whole table operations it will not be possible to +reduce the number of keys scanned over when the selection is specified +only by an opaque procedure. + +Transaction boundaries present the most intriguing area. Transaction +boundaries are actually a feature of the "Comprehensive Language" of the +Relational database and not of the database. Scheme would seem to +provide the opportunity for an extremely clean semantics for transaction +boundaries since the builtin procedures with side effects are small in +number and easily identified. + +These side-effect builtin procedures might all be portably redefined to +versions which properly handled transactions. Compiled library routines +would need to be recompiled as well. Many system extensions +(delete-file, system, etc.) would also need to be redefined. + +@noindent +There are 2 scope issues that must be resolved for multiprocess +transaction boundaries: + +@table @asis +@item Process scope +The actions captured by a transaction should be only for the process +which invoked the start of transaction. Although standard Scheme does +not provide process primitives as such, @code{dynamic-wind} would +provide a workable hook into process switching for many implementations. +@item Shared utilities with state +Some shared utilities have state which should @emph{not} be part of a +transaction. An example would be calling a pseudo-random number +generator. If the success of a transaction depended on the +pseudo-random number and failed, the state of the generator would be set +back. Subsequent calls would keep returning the same number and keep +failing. + +Pseudo-random number generators are not reentrant and so would require +locks in order to operate properly in a multiprocess environment. Are +all examples of utilities whose state should not part of transactions +also non-reentrant? If so, perhaps suspending transaction capture for +the duration of locks would fix it. +@end table + +@node Database Utilities, , Unresolved Issues, Relational Database +@subsection Database Utilities + +@code{(require 'database-utilities)} + +@noindent +This enhancement wraps a utility layer on @code{relational-database} +which provides: +@itemize @bullet +@item +Automatic loading of the appropriate base-table package when opening a +database. +@item +Automatic execution of initialization commands stored in database. +@item +Transparent execution of database commands stored in @code{*commands*} +table in database. +@end itemize + +@noindent +Also included are utilities which provide: +@itemize @bullet +@item +Data definition from Scheme lists and +@item +Report generation +@end itemize +@noindent +for any SLIB relational database. + +@defun create-database filename base-table-type +Returns an open, nearly empty enhanced (with @code{*commands*} table) +relational database (with base-table type @var{base-table-type}) +associated with @var{filename}. +@end defun + +@defun open-database filename +@defunx open-database filename base-table-type +Returns an open enchanced relational database associated with +@var{filename}. The database will be opened with base-table type +@var{base-table-type}) if supplied. If @var{base-table-type} is not +supplied, @code{open-database} will attempt to deduce the correct +base-table-type. If the database can not be opened or if it lacks the +@code{*commands*} table, @code{#f} is returned. + +@defunx open-database! filename +@defunx open-database! filename base-table-type +Returns @emph{mutable} open enchanced relational database @dots{} +@end defun + +@noindent +The table @code{*commands*} in an @dfn{enhanced} relational-database has +the fields (with domains): +@example +@group +PRI name symbol + parameters parameter-list + procedure expression + documentation string +@end group +@end example + +The @code{parameters} field is a foreign key (domain +@code{parameter-list}) of the @code{*catalog-data*} table and should +have the value of a table described by @code{*parameter-columns*}. This +@code{parameter-list} table describes the arguments suitable for passing +to the associated command. The intent of this table is to be of a form +such that different user-interfaces (for instance, pull-down menus or +plain-text queries) can operate from the same table. A +@code{parameter-list} table has the following fields: +@example +@group +PRI index uint + name symbol + arity parameter-arity + domain domain + default expression + documentation string +@end group +@end example + +The @code{arity} field can take the values: + +@table @code +@item single +Requires a single parameter of the specified domain. +@item optional +A single parameter of the specified domain or zero parameters is +acceptable. +@item boolean +A single boolean parameter or zero parameters (in which case @code{#f} +is substituted) is acceptable. +@item nary +Any number of parameters of the specified domain are acceptable. The +argument passed to the command function is always a list of the +parameters. +@item nary1 +One or more of parameters of the specified domain are acceptable. The +argument passed to the command function is always a list of the +parameters. +@end table + +The @code{domain} field specifies the domain which a parameter or +parameters in the @code{index}th field must satisfy. + +The @code{default} field is an expression whose value is either +@code{#f} or a procedure of no arguments which returns a parameter or +parameter list as appropriate. If the expression's value is @code{#f} +then no default is appropriate for this parameter. Note that since the +@code{default} procedure is called every time a default parameter is +needed for this column, @dfn{sticky} defaults can be implemented using +shared state with the domain-integrity-rule. + +@subsubheading Invoking Commands + +When an enhanced relational-database is called with a symbol which +matches a @var{name} in the @code{*commands*} table, the associated +procedure expression is evaluated and applied to the enhanced +relational-database. A procedure should then be returned which the user +can invoke on (optional) arguments. + +The command @code{*initialize*} is special. If present in the +@code{*commands*} table, @code{open-database} or @code{open-database!} +will return the value of the @code{*initialize*} command. Notice that +arbitrary code can be run when the @code{*initialize*} procedure is +automatically applied to the enhanced relational-database. + +Note also that if you wish to shadow or hide from the user +relational-database methods described in @ref{Relational Database +Operations}, this can be done by a dispatch in the closure returned by +the @code{*initialize*} expression rather than by entries in the +@code{*commands*} table if it is desired that the underlying methods +remain accessible to code in the @code{*commands*} table. + +@defun make-command-server rdb table-name +Returns a procedure of 2 arguments, a (symbol) command and a call-back +procedure. When this returned procedure is called, it looks up +@var{command} in table @var{table-name} and calls the call-back +procedure with arguments: +@table @var +@item command +The @var{command} +@item command-value +The result of evaluating the expression in the @var{procedure} field of +@var{table-name} and calling it with @var{rdb}. +@item parameter-name +A list of the @dfn{official} name of each parameter. Corresponds to the +@code{name} field of the @var{command}'s parameter-table. +@item positions +A list of the positive integer index of each parameter. Corresponds to +the @code{index} field of the @var{command}'s parameter-table. +@item arities +A list of the arities of each parameter. Corresponds to the +@code{arity} field of the @var{command}'s parameter-table. For a +description of @code{arity} see table above. +@item defaults +A list of the defaults for each parameter. Corresponds to +the @code{defaults} field of the @var{command}'s parameter-table. +@item domain-integrity-rules +A list of procedures (one for each parameter) which tests whether a +value for a parameter is acceptable for that parameter. The procedure +should be called with each datum in the list for @code{nary} arity +parameters. +@item aliases +A list of lists of @code{(@r{alias} @r{parameter-name})}. There can be +more than one alias per @var{parameter-name}. +@end table +@end defun + +For information about parameters, @xref{Parameter lists}. Here is an +example of setting up a command with arguments and parsing those +arguments from a @code{getopt} style argument list (@pxref{Getopt}). + +@example +(require 'database-utilities) +(require 'parameters) +(require 'getopt) + +(define my-rdb (create-database #f 'alist-table)) + +(define-tables my-rdb + '(foo-params + *parameter-columns* + *parameter-columns* + ((1 first-argument single string "hithere" "first argument") + (2 flag boolean boolean #f "a flag"))) + '(foo-pnames + ((name string)) + ((parameter-index uint)) + (("l" 1) + ("a" 2))) + '(my-commands + ((name symbol)) + ((parameters parameter-list) + (parameter-names parameter-name-translation) + (procedure expression) + (documentation string)) + ((foo + foo-params + foo-pnames + (lambda (rdb) (lambda (foo aflag) (print foo aflag))) + "test command arguments")))) + +(define (dbutil:serve-command-line rdb command-table + command argc argv) + (set! argv (if (vector? argv) (vector->list argv) argv)) + ((make-command-server rdb command-table) + command + (lambda (comname comval options positions + arities types defaults dirs aliases) + (apply comval (getopt->arglist argc argv options positions + arities types defaults dirs aliases))))) + +(define (test) + (set! *optind* 1) + (dbutil:serve-command-line + my-rdb 'my-commands 'foo 4 '("dummy" "-l" "foo" "-a"))) +(test) +@print{} +"foo" #t +@end example + +Some commands are defined in all extended relational-databases. The are +called just like @ref{Relational Database Operations}. + +@defun add-domain domain-row +Adds @var{domain-row} to the @dfn{domains} table if there is no row in +the domains table associated with key @code{(car @var{domain-row})} and +returns @code{#t}. Otherwise returns @code{#f}. + +For the fields and layout of the domain table, @xref{Catalog +Representation} +@end defun + +@defun delete-domain domain-name +Removes and returns the @var{domain-name} row from the @dfn{domains} +table. +@end defun + +@defun domain-checker domain +Returns a procedure to check an argument for conformance to domain +@var{domain}. +@end defun + +@subheading Defining Tables + +@deffn Procedure define-tables rdb spec-0 @dots{} +Adds tables as specified in @var{spec-0} @dots{} to the open +relational-database @var{rdb}. Each @var{spec} has the form: + +@lisp +(@r{} @r{} @r{} @r{}) +@end lisp +or +@lisp +(@r{} @r{} @r{} @r{}) +@end lisp + +where @r{} is the table name, @r{} is the symbol +name of a descriptor table, @r{} and +@r{} describe the primary keys and other fields +respectively, and @r{} is a list of data rows to be added to the +table. + +@r{} and @r{} are lists of field +descriptors of the form: + +@lisp +(@r{} @r{}) +@end lisp +or +@lisp +(@r{} @r{} @r{}) +@end lisp + +where @r{} is the column name, @r{} is the domain +of the column, and @r{} is an expression whose +value is a procedure of one argument (and returns non-@code{#f} to +signal an error). + +If @r{} is not a defined domain name and it matches the name of +this table or an already defined (in one of @var{spec-0} @dots{}) single +key field table, a foriegn-key domain will be created for it. +@end deffn + + +@deffn Procedure create-report rdb destination report-name table +@deffnx Procedure create-report rdb destination report-name +The symbol @var{report-name} must be primary key in the table named +@code{*reports*} in the relational database @var{rdb}. +@var{destination} is a port, string, or symbol. If @var{destination} is +a: + +@table @asis +@item port +The table is created as ascii text and written to that port. +@item string +The table is created as ascii text and written to the file named by +@var{destination}. +@item symbol +@var{destination} is the primary key for a row in the table named *printers*. +@end table + +Each row in the table *reports* has the fields: + +@table @asis +@item name +The report name. +@item default-table +The table to report on if none is specified. +@item header, footer +A @code{format} string. At the beginning and end of each page +respectively, @code{format} is called with this string and the (list of) +column-names of this table. +@item reporter +A @code{format} string. For each row in the table, @code{format} is +called with this string and the row. +@item minimum-break +The minimum number of lines into which the report lines for a row can be +broken. Use @code{0} if a row's lines should not be broken over page +boundaries. +@end table + +Each row in the table *printers* has the fields: + +@table @asis +@item name +The printer name. +@item print-procedure +The procedure to call to actually print. +@end table + +The report is prepared as follows: + +@itemize +@item +@code{Format} (@pxref{Format}) is called with the @code{header} field +and the (list of) @code{column-names} of the table. +@item +@code{Format} is called with the @code{reporter} field and (on +successive calls) each record in the natural order for the table. A +count is kept of the number of newlines output by format. When the +number of newlines to be output exceeds the number of lines per page, +the set of lines will be broken if there are more than +@code{minimum-break} left on this page and the number of lines for this +row is larger or equal to twice @code{minimum-break}. +@item +@code{Format} is called with the @code{footer} field and the (list of) +@code{column-names} of the table. The footer field should not output a +newline. +@item +A new page is output. +@item +This entire process repeats until all the rows are output. +@end itemize +@end deffn + +@noindent +The following example shows a new database with the name of +@file{foo.db} being created with tables describing processor families +and processor/os/compiler combinations. + +@noindent +The database command @code{define-tables} is defined to call +@code{define-tables} with its arguments. The database is also +configured to print @samp{Welcome} when the database is opened. The +database is then closed and reopened. + +@example +(require 'database-utilities) +(define my-rdb (create-database "foo.db" 'alist-table)) + +(define-tables my-rdb + '(*commands* + ((name symbol)) + ((parameters parameter-list) + (procedure expression) + (documentation string)) + ((define-tables + no-parameters + no-parameter-names + (lambda (rdb) (lambda specs (apply define-tables rdb specs))) + "Create or Augment tables from list of specs") + (*initialize* + no-parameters + no-parameter-names + (lambda (rdb) (display "Welcome") (newline) rdb) + "Print Welcome")))) + +((my-rdb 'define-tables) + '(processor-family + ((family atom)) + ((also-ran processor-family)) + ((m68000 #f) + (m68030 m68000) + (i386 8086) + (8086 #f) + (powerpc #f))) + + '(platform + ((name symbol)) + ((processor processor-family) + (os symbol) + (compiler symbol)) + ((aix powerpc aix -) + (amiga-dice-c m68000 amiga dice-c) + (amiga-aztec m68000 amiga aztec) + (amiga-sas/c-5.10 m68000 amiga sas/c) + (atari-st-gcc m68000 atari gcc) + (atari-st-turbo-c m68000 atari turbo-c) + (borland-c-3.1 8086 ms-dos borland-c) + (djgpp i386 ms-dos gcc) + (linux i386 linux gcc) + (microsoft-c 8086 ms-dos microsoft-c) + (os/2-emx i386 os/2 gcc) + (turbo-c-2 8086 ms-dos turbo-c) + (watcom-9.0 i386 ms-dos watcom)))) + +((my-rdb 'close-database)) + +(set! my-rdb (open-database "foo.db" 'alist-table)) +@print{} +Welcome +@end example + +@node Weight-Balanced Trees, Structures, Relational Database, Data Structures +@section Weight-Balanced Trees + +@code{(require 'wt-tree)} + +@cindex trees, balanced binary +@cindex balanced binary trees +@cindex binary trees +@cindex weight-balanced binary trees +Balanced binary trees are a useful data structure for maintaining large +sets of ordered objects or sets of associations whose keys are ordered. +MIT Scheme has an comprehensive implementation of weight-balanced binary +trees which has several advantages over the other data structures for +large aggregates: + +@itemize @bullet +@item +In addition to the usual element-level operations like insertion, +deletion and lookup, there is a full complement of collection-level +operations, like set intersection, set union and subset test, all of +which are implemented with good orders of growth in time and space. +This makes weight balanced trees ideal for rapid prototyping of +functionally derived specifications. + +@item +An element in a tree may be indexed by its position under the ordering +of the keys, and the ordinal position of an element may be determined, +both with reasonable efficiency. + +@item +Operations to find and remove minimum element make weight balanced trees +simple to use for priority queues. + +@item +The implementation is @emph{functional} rather than @emph{imperative}. +This means that operations like `inserting' an association in a tree do +not destroy the old tree, in much the same way that @code{(+ 1 x)} +modifies neither the constant 1 nor the value bound to @code{x}. The +trees are referentially transparent thus the programmer need not worry +about copying the trees. Referential transparency allows space +efficiency to be achieved by sharing subtrees. + +@end itemize + +These features make weight-balanced trees suitable for a wide range of +applications, especially those that +require large numbers of sets or discrete maps. Applications that have +a few global databases and/or concentrate on element-level operations like +insertion and lookup are probably better off using hash-tables or +red-black trees. + +The @emph{size} of a tree is the number of associations that it +contains. Weight balanced binary trees are balanced to keep the sizes +of the subtrees of each node within a constant factor of each other. +This ensures logarithmic times for single-path operations (like lookup +and insertion). A weight balanced tree takes space that is proportional +to the number of associations in the tree. For the current +implementation, the constant of proportionality is six words per +association. + +@cindex binary trees, as sets +@cindex binary trees, as discrete maps +@cindex sets, using binary trees +@cindex discrete maps, using binary trees +Weight balanced trees can be used as an implementation for either +discrete sets or discrete maps (associations). Sets are implemented by +ignoring the datum that is associated with the key. Under this scheme +if an associations exists in the tree this indicates that the key of the +association is a member of the set. Typically a value such as +@code{()}, @code{#t} or @code{#f} is associated with the key. + +Many operations can be viewed as computing a result that, depending on +whether the tree arguments are thought of as sets or maps, is known by +two different names. +An example is @code{wt-tree/member?}, which, when +regarding the tree argument as a set, computes the set membership operation, but, +when regarding the tree as a discrete map, @code{wt-tree/member?} is the +predicate testing if the map is defined at an element in its domain. +Most names in this package have been chosen based on interpreting the +trees as sets, hence the name @code{wt-tree/member?} rather than +@code{wt-tree/defined-at?}. + + +@cindex run-time-loadable option +@cindex option, run-time-loadable +The weight balanced tree implementation is a run-time-loadable option. +To use weight balanced trees, execute + +@example +(load-option 'wt-tree) +@end example +@findex load-option + +@noindent +once before calling any of the procedures defined here. + + +@menu +* Construction of Weight-Balanced Trees:: +* Basic Operations on Weight-Balanced Trees:: +* Advanced Operations on Weight-Balanced Trees:: +* Indexing Operations on Weight-Balanced Trees:: +@end menu + +@node Construction of Weight-Balanced Trees, Basic Operations on Weight-Balanced Trees, Weight-Balanced Trees, Weight-Balanced Trees +@subsection Construction of Weight-Balanced Trees + +Binary trees require there to be a total order on the keys used to +arrange the elements in the tree. Weight balanced trees are organized +by @emph{types}, where the type is an object encapsulating the ordering +relation. Creating a tree is a two-stage process. First a tree type +must be created from the predicate which gives the ordering. The tree type +is then used for making trees, either empty or singleton trees or trees +from other aggregate structures like association lists. Once created, a +tree `knows' its type and the type is used to test compatibility between +trees in operations taking two trees. Usually a small number of tree +types are created at the beginning of a program and used many times +throughout the program's execution. + +@deffn {procedure+} make-wt-tree-type keywt-tree tree-type alist +Returns a newly allocated weight-balanced tree that contains the same +associations as @var{alist}. This procedure is equivalent to: + +@example +(lambda (type alist) + (let ((tree (make-wt-tree type))) + (for-each (lambda (association) + (wt-tree/add! tree + (car association) + (cdr association))) + alist) + tree)) +@end example +@end deffn + + + +@node Basic Operations on Weight-Balanced Trees, Advanced Operations on Weight-Balanced Trees, Construction of Weight-Balanced Trees, Weight-Balanced Trees +@subsection Basic Operations on Weight-Balanced Trees + +This section describes the basic tree operations on weight balanced +trees. These operations are the usual tree operations for insertion, +deletion and lookup, some predicates and a procedure for determining the +number of associations in a tree. + +@deffn {procedure+} wt-tree? object +Returns @code{#t} if @var{object} is a weight-balanced tree, otherwise +returns @code{#f}. +@end deffn + +@deffn {procedure+} wt-tree/empty? wt-tree +Returns @code{#t} if @var{wt-tree} contains no associations, otherwise +returns @code{#f}. +@end deffn + +@deffn {procedure+} wt-tree/size wt-tree +Returns the number of associations in @var{wt-tree}, an exact +non-negative integer. This operation takes constant time. +@end deffn + + +@deffn {procedure+} wt-tree/add wt-tree key datum +Returns a new tree containing all the associations in @var{wt-tree} and +the association of @var{datum} with @var{key}. If @var{wt-tree} already +had an association for @var{key}, the new association overrides the old. +The average and worst-case times required by this operation are +proportional to the logarithm of the number of associations in +@var{wt-tree}. +@end deffn + +@deffn {procedure+} wt-tree/add! wt-tree key datum +Associates @var{datum} with @var{key} in @var{wt-tree} and returns an +unspecified value. If @var{wt-tree} already has an association for +@var{key}, that association is replaced. The average and worst-case +times required by this operation are proportional to the logarithm of +the number of associations in @var{wt-tree}. +@end deffn + +@deffn {procedure+} wt-tree/member? key wt-tree +Returns @code{#t} if @var{wt-tree} contains an association for +@var{key}, otherwise returns @code{#f}. The average and worst-case +times required by this operation are proportional to the logarithm of +the number of associations in @var{wt-tree}. +@end deffn + +@deffn {procedure+} wt-tree/lookup wt-tree key default +Returns the datum associated with @var{key} in @var{wt-tree}. If +@var{wt-tree} doesn't contain an association for @var{key}, +@var{default} is returned. The average and worst-case times required by +this operation are proportional to the logarithm of the number of +associations in @var{wt-tree}. +@end deffn + +@deffn {procedure+} wt-tree/delete wt-tree key +Returns a new tree containing all the associations in @var{wt-tree}, +except that if @var{wt-tree} contains an association for @var{key}, it +is removed from the result. The average and worst-case times required +by this operation are proportional to the logarithm of the number of +associations in @var{wt-tree}. +@end deffn + +@deffn {procedure+} wt-tree/delete! wt-tree key +If @var{wt-tree} contains an association for @var{key} the association +is removed. Returns an unspecified value. The average and worst-case +times required by this operation are proportional to the logarithm of +the number of associations in @var{wt-tree}. +@end deffn + + +@node Advanced Operations on Weight-Balanced Trees, Indexing Operations on Weight-Balanced Trees, Basic Operations on Weight-Balanced Trees, Weight-Balanced Trees +@subsection Advanced Operations on Weight-Balanced Trees + +In the following the @emph{size} of a tree is the number of associations +that the tree contains, and a @emph{smaller} tree contains fewer +associations. + +@deffn {procedure+} wt-tree/split< wt-tree bound +Returns a new tree containing all and only the associations in +@var{wt-tree} which have a key that is less than @var{bound} in the +ordering relation of the tree type of @var{wt-tree}. The average and +worst-case times required by this operation are proportional to the +logarithm of the size of @var{wt-tree}. +@end deffn + +@deffn {procedure+} wt-tree/split> wt-tree bound +Returns a new tree containing all and only the associations in +@var{wt-tree} which have a key that is greater than @var{bound} in the +ordering relation of the tree type of @var{wt-tree}. The average and +worst-case times required by this operation are proportional to the +logarithm of size of @var{wt-tree}. +@end deffn + +@deffn {procedure+} wt-tree/union wt-tree-1 wt-tree-2 +Returns a new tree containing all the associations from both trees. +This operation is asymmetric: when both trees have an association for +the same key, the returned tree associates the datum from @var{wt-tree-2} +with the key. Thus if the trees are viewed as discrete maps then +@code{wt-tree/union} computes the map override of @var{wt-tree-1} by +@var{wt-tree-2}. If the trees are viewed as sets the result is the set +union of the arguments. +The worst-case time required by this operation +is proportional to the sum of the sizes of both trees. +If the minimum key of one tree is greater than the maximum key of +the other tree then the time required is at worst proportional to +the logarithm of the size of the larger tree. +@end deffn + +@deffn {procedure+} wt-tree/intersection wt-tree-1 wt-tree-2 +Returns a new tree containing all and only those associations from +@var{wt-tree-1} which have keys appearing as the key of an association +in @var{wt-tree-2}. Thus the associated data in the result are those +from @var{wt-tree-1}. If the trees are being used as sets the result is +the set intersection of the arguments. As a discrete map operation, +@code{wt-tree/intersection} computes the domain restriction of +@var{wt-tree-1} to (the domain of) @var{wt-tree-2}. +The time required by this operation is never worse that proportional to +the sum of the sizes of the trees. +@end deffn + +@deffn {procedure+} wt-tree/difference wt-tree-1 wt-tree-2 +Returns a new tree containing all and only those associations from +@var{wt-tree-1} which have keys that @emph{do not} appear as the key of +an association in @var{wt-tree-2}. If the trees are viewed as sets the +result is the asymmetric set difference of the arguments. As a discrete +map operation, it computes the domain restriction of @var{wt-tree-1} to +the complement of (the domain of) @var{wt-tree-2}. +The time required by this operation is never worse that proportional to +the sum of the sizes of the trees. +@end deffn + + +@deffn {procedure+} wt-tree/subset? wt-tree-1 wt-tree-2 +Returns @code{#t} iff the key of each association in @var{wt-tree-1} is +the key of some association in @var{wt-tree-2}, otherwise returns @code{#f}. +Viewed as a set operation, @code{wt-tree/subset?} is the improper subset +predicate. +A proper subset predicate can be constructed: + +@example +(define (proper-subset? s1 s2) + (and (wt-tree/subset? s1 s2) + (< (wt-tree/size s1) (wt-tree/size s2)))) +@end example + +As a discrete map operation, @code{wt-tree/subset?} is the subset +test on the domain(s) of the map(s). In the worst-case the time +required by this operation is proportional to the size of +@var{wt-tree-1}. +@end deffn + + +@deffn {procedure+} wt-tree/set-equal? wt-tree-1 wt-tree-2 +Returns @code{#t} iff for every association in @var{wt-tree-1} there is +an association in @var{wt-tree-2} that has the same key, and @emph{vice +versa}. + +Viewing the arguments as sets @code{wt-tree/set-equal?} is the set +equality predicate. As a map operation it determines if two maps are +defined on the same domain. + +This procedure is equivalent to + +@example +(lambda (wt-tree-1 wt-tree-2) + (and (wt-tree/subset? wt-tree-1 wt-tree-2 + (wt-tree/subset? wt-tree-2 wt-tree-1))) +@end example + +In the worst-case the time required by this operation is proportional to +the size of the smaller tree. +@end deffn + + +@deffn {procedure+} wt-tree/fold combiner initial wt-tree +This procedure reduces @var{wt-tree} by combining all the associations, +using an reverse in-order traversal, so the associations are visited in +reverse order. @var{Combiner} is a procedure of three arguments: a key, +a datum and the accumulated result so far. Provided @var{combiner} +takes time bounded by a constant, @code{wt-tree/fold} takes time +proportional to the size of @var{wt-tree}. + +A sorted association list can be derived simply: + +@example +(wt-tree/fold (lambda (key datum list) + (cons (cons key datum) list)) + '() + @var{wt-tree})) +@end example + +The data in the associations can be summed like this: + +@example +(wt-tree/fold (lambda (key datum sum) (+ sum datum)) + 0 + @var{wt-tree}) +@end example +@end deffn + +@deffn {procedure+} wt-tree/for-each action wt-tree +This procedure traverses the tree in-order, applying @var{action} to +each association. +The associations are processed in increasing order of their keys. +@var{Action} is a procedure of two arguments which take the key and +datum respectively of the association. +Provided @var{action} takes time bounded by a constant, +@code{wt-tree/for-each} takes time proportional to in the size of +@var{wt-tree}. +The example prints the tree: + +@example +(wt-tree/for-each (lambda (key value) + (display (list key value))) + @var{wt-tree})) +@end example +@end deffn + + +@node Indexing Operations on Weight-Balanced Trees, , Advanced Operations on Weight-Balanced Trees, Weight-Balanced Trees +@subsection Indexing Operations on Weight-Balanced Trees + +Weight balanced trees support operations that view the tree as sorted +sequence of associations. Elements of the sequence can be accessed by +position, and the position of an element in the sequence can be +determined, both in logarthmic time. + +@deffn {procedure+} wt-tree/index wt-tree index +@deffnx {procedure+} wt-tree/index-datum wt-tree index +@deffnx {procedure+} wt-tree/index-pair wt-tree index +Returns the 0-based @var{index}th association of @var{wt-tree} in the +sorted sequence under the tree's ordering relation on the keys. +@code{wt-tree/index} returns the @var{index}th key, +@code{wt-tree/index-datum} returns the datum associated with the +@var{index}th key and @code{wt-tree/index-pair} returns a new pair +@code{(@var{key} . @var{datum})} which is the @code{cons} of the @var{index}th +key and its datum. The average and worst-case times required by this +operation are proportional to the logarithm of the number of +associations in the tree. + +These operations signal an error if the tree is empty, if +@var{index}@code{<0}, or if @var{index} is greater than or equal to the +number of associations in the tree. + +Indexing can be used to find the median and maximum keys in the tree as +follows: + +@example +median: (wt-tree/index @var{wt-tree} (quotient (wt-tree/size @var{wt-tree}) 2)) + +maximum: (wt-tree/index @var{wt-tree} (-1+ (wt-tree/size @var{wt-tree}))) +@end example +@end deffn + +@deffn {procedure+} wt-tree/rank wt-tree key +Determines the 0-based position of @var{key} in the sorted sequence of +the keys under the tree's ordering relation, or @code{#f} if the tree +has no association with for @var{key}. This procedure returns either an +exact non-negative integer or @code{#f}. The average and worst-case +times required by this operation are proportional to the logarithm of +the number of associations in the tree. +@end deffn + +@deffn {procedure+} wt-tree/min wt-tree +@deffnx {procedure+} wt-tree/min-datum wt-tree +@deffnx {procedure+} wt-tree/min-pair wt-tree +Returns the association of @var{wt-tree} that has the least key under the tree's ordering relation. +@code{wt-tree/min} returns the least key, +@code{wt-tree/min-datum} returns the datum associated with the +least key and @code{wt-tree/min-pair} returns a new pair +@code{(key . datum)} which is the @code{cons} of the minimum key and its datum. +The average and worst-case times required by this operation are +proportional to the logarithm of the number of associations in the tree. + +These operations signal an error if the tree is empty. +They could be written +@example +(define (wt-tree/min tree) (wt-tree/index tree 0)) +(define (wt-tree/min-datum tree) (wt-tree/index-datum tree 0)) +(define (wt-tree/min-pair tree) (wt-tree/index-pair tree 0)) +@end example +@end deffn + +@deffn {procedure+} wt-tree/delete-min wt-tree +Returns a new tree containing all of the associations in @var{wt-tree} +except the association with the least key under the @var{wt-tree}'s +ordering relation. An error is signalled if the tree is empty. The +average and worst-case times required by this operation are proportional +to the logarithm of the number of associations in the tree. This +operation is equivalent to + +@example +(wt-tree/delete @var{wt-tree} (wt-tree/min @var{wt-tree})) +@end example +@end deffn + + +@deffn {procedure+} wt-tree/delete-min! wt-tree +Removes the association with the least key under the @var{wt-tree}'s +ordering relation. An error is signalled if the tree is empty. The +average and worst-case times required by this operation are proportional +to the logarithm of the number of associations in the tree. This +operation is equivalent to + +@example +(wt-tree/delete! @var{wt-tree} (wt-tree/min @var{wt-tree})) +@end example +@end deffn + + + +@node Structures, , Weight-Balanced Trees, Data Structures +@section Structures + +@code{(require 'struct)} (uses defmacros) + +@code{defmacro}s which implement @dfn{records} from the book +@cite{Essentials of Programming Languages} by Daniel P. Friedman, M. +Wand and C.T. Haynes. Copyright 1992 Jeff Alexander, Shinnder Lee, and +Lewis Patterson@refill + +Matthew McDonald added field setters. + +@defmac define-record tag (var1 var2 @dots{}) +Defines several functions pertaining to record-name @var{tag}: + +@defun make-@var{tag} var1 var2 @dots{} +@end defun +@defun @var{tag}? obj +@end defun +@defun @var{tag}->var1 obj +@end defun +@defun @var{tag}->var2 obj +@end defun +@dots{} +@defun set-@var{@var{tag}}-var1! obj val +@end defun +@defun set-@var{@var{tag}}-var2! obj val +@end defun +@dots{} + +Here is an example of its use. + +@example +(define-record term (operator left right)) +@result{} # +(define foo (make-term 'plus 1 2)) +@result{} foo +(term-left foo) +@result{} 1 +(set-term-left! foo 2345) +@result{} # +(term-left foo) +@result{} 2345 +@end example +@end defmac + +@defmac variant-case exp (tag (var1 var2 @dots{}) body) @dots{} +executes the following for the matching clause: + +@example +((lambda (@var{var1} @var{var} @dots{}) @var{body}) + (@var{tag->var1} @var{exp}) + (@var{tag->var2} @var{exp}) @dots{}) +@end example +@end defmac + +@node Macros, Numerics, Data Structures, Top +@chapter Macros +@menu +* Defmacro:: Supported by all implementations + +* R4RS Macros:: 'macro +* Macro by Example:: 'macro-by-example +* Macros That Work:: 'macros-that-work +* Syntactic Closures:: 'syntactic-closures +* Syntax-Case Macros:: 'syntax-case + +Syntax extensions (macros) included with SLIB. Also @xref{Structures}. + +* Fluid-Let:: 'fluid-let +* Yasos:: 'yasos, 'oop, 'collect +@end menu + + +@node Defmacro, R4RS Macros, Macros, Macros +@section Defmacro + +Defmacros are supported by all implementations. +@c See also @code{gentemp}, in @ref{Macros}. + +@defun gentemp +Returns a new (interned) symbol each time it is called. The symbol +names are implementation-dependent +@lisp +(gentemp) @result{} scm:G0 +(gentemp) @result{} scm:G1 +@end lisp +@end defun + +@defun defmacro:eval e +Returns the @code{slib:eval} of expanding all defmacros in scheme +expression @var{e}. +@end defun + +@defun defmacro:load filename +@var{filename} should be a string. If filename names an existing file, +the @code{defmacro:load} procedure reads Scheme source code expressions +and definitions from the file and evaluates them sequentially. These +source code expressions and definitions may contain defmacro +definitions. The @code{macro:load} procedure does not affect the values +returned by @code{current-input-port} and +@code{current-output-port}.@refill +@end defun + +@defun defmacro? sym +Returns @code{#t} if @var{sym} has been defined by @code{defmacro}, +@code{#f} otherwise. +@end defun + +@defun macroexpand-1 form +@defunx macroexpand form +If @var{form} is a macro call, @code{macroexpand-1} will expand the +macro call once and return it. A @var{form} is considered to be a macro +call only if it is a cons whose @code{car} is a symbol for which a +@code{defmacr} has been defined. + +@code{macroexpand} is similar to @code{macroexpand-1}, but repeatedly +expands @var{form} until it is no longer a macro call. +@end defun + +@defmac defmacro name lambda-list form @dots{} +When encountered by @code{defmacro:eval}, @code{defmacro:macroexpand*}, +or @code{defmacro:load} defines a new macro which will henceforth be +expanded when encountered by @code{defmacro:eval}, +@code{defmacro:macroexpand*}, or @code{defmacro:load}. +@end defmac + +@subsection Defmacroexpand +@code{(require 'defmacroexpand)} + +@defun defmacro:expand* e +Returns the result of expanding all defmacros in scheme expression +@var{e}. +@end defun + +@node R4RS Macros, Macro by Example, Defmacro, Macros +@section R4RS Macros + +@code{(require 'macro)} is the appropriate call if you want R4RS +high-level macros but don't care about the low level implementation. If +an SLIB R4RS macro implementation is already loaded it will be used. +Otherwise, one of the R4RS macros implemetations is loaded. + +The SLIB R4RS macro implementations support the following uniform +interface: + +@defun macro:expand sexpression +Takes an R4RS expression, macro-expands it, and returns the result of +the macro expansion. +@end defun + +@defun macro:eval sexpression +Takes an R4RS expression, macro-expands it, evals the result of the +macro expansion, and returns the result of the evaluation. +@end defun + +@deffn Procedure macro:load filename +@var{filename} should be a string. If filename names an existing file, +the @code{macro:load} procedure reads Scheme source code expressions and +definitions from the file and evaluates them sequentially. These source +code expressions and definitions may contain macro definitions. The +@code{macro:load} procedure does not affect the values returned by +@code{current-input-port} and @code{current-output-port}.@refill +@end deffn + +@node Macro by Example, Macros That Work, R4RS Macros, Macros +@section Macro by Example + +@code{(require 'macro-by-example)} + +A vanilla implementation of @cite{Macro by Example} (Eugene Kohlbecker, +R4RS) by Dorai Sitaram, (dorai@@cs.rice.edu) using @code{defmacro}. + +@itemize @bullet + +@item +generating hygienic global @code{define-syntax} Macro-by-Example macros +@strong{cheaply}. + +@item +can define macros which use @code{...}. + +@item +needn't worry about a lexical variable in a macro definition +clashing with a variable from the macro use context + +@item +don't suffer the overhead of redefining the repl if @code{defmacro} +natively supported (most implementations) + +@end itemize +@subsection Caveat +These macros are not referentially transparent (@pxref{Macros, , ,r4rs, +Revised(4) Scheme}). Lexically scoped macros (i.e., @code{let-syntax} +and @code{letrec-syntax}) are not supported. In any case, the problem +of referential transparency gains poignancy only when @code{let-syntax} +and @code{letrec-syntax} are used. So you will not be courting +large-scale disaster unless you're using system-function names as local +variables with unintuitive bindings that the macro can't use. However, +if you must have the full @cite{r4rs} macro functionality, look to the +more featureful (but also more expensive) versions of syntax-rules +available in slib @ref{Macros That Work}, @ref{Syntactic Closures}, and +@ref{Syntax-Case Macros}. + +@defmac define-syntax keyword transformer-spec +The @var{keyword} is an identifier, and the @var{transformer-spec} +should be an instance of @code{syntax-rules}. + +The top-level syntactic environment is extended by binding the +@var{keyword} to the specified transformer. + +@example +(define-syntax let* + (syntax-rules () + ((let* () body1 body2 ...) + (let () body1 body2 ...)) + ((let* ((name1 val1) (name2 val2) ...) + body1 body2 ...) + (let ((name1 val1)) + (let* (( name2 val2) ...) + body1 body2 ...))))) +@end example +@end defmac + +@defmac syntax-rules literals syntax-rule @dots{} +@var{literals} is a list of identifiers, and each @var{syntax-rule} +should be of the form + +@code{(@var{pattern} @var{template})} + +where the @var{pattern} and @var{template} are as in the grammar above. + +An instance of @code{syntax-rules} produces a new macro transformer by +specifying a sequence of hygienic rewrite rules. A use of a macro whose +keyword is associated with a transformer specified by +@code{syntax-rules} is matched against the patterns contained in the +@var{syntax-rule}s, beginning with the leftmost @var{syntax-rule}. +When a match is found, the macro use is trancribed hygienically +according to the template. + +Each pattern begins with the keyword for the macro. This keyword is not +involved in the matching and is not considered a pattern variable or +literal identifier. +@end defmac + +@node Macros That Work, Syntactic Closures, Macro by Example, Macros +@section Macros That Work + +@code{(require 'macros-that-work)} + +@cite{Macros That Work} differs from the other R4RS macro +implementations in that it does not expand derived expression types to +primitive expression types. + +@defun macro:expand expression +@defunx macwork:expand expression +Takes an R4RS expression, macro-expands it, and returns the result of +the macro expansion. +@end defun + +@defun macro:eval expression +@defunx macwork:eval expression +@code{macro:eval} returns the value of @var{expression} in the current +top level environment. @var{expression} can contain macro definitions. +Side effects of @var{expression} will affect the top level +environment.@refill +@end defun + +@deffn Procedure macro:load filename +@deffnx Procedure macwork:load filename +@var{filename} should be a string. If filename names an existing file, +the @code{macro:load} procedure reads Scheme source code expressions and +definitions from the file and evaluates them sequentially. These source +code expressions and definitions may contain macro definitions. The +@code{macro:load} procedure does not affect the values returned by +@code{current-input-port} and @code{current-output-port}.@refill +@end deffn + +References: + +The @cite{Revised^4 Report on the Algorithmic Language Scheme} Clinger +and Rees [editors]. To appear in LISP Pointers. Also available as a +technical report from the University of Oregon, MIT AI Lab, and +Cornell.@refill + +@center Macros That Work. Clinger and Rees. POPL '91. + +The supported syntax differs from the R4RS in that vectors are allowed +as patterns and as templates and are not allowed as pattern or template +data. + +@example +transformer spec @expansion{} (syntax-rules literals rules) + +rules @expansion{} () + | (rule . rules) + +rule @expansion{} (pattern template) + +pattern @expansion{} pattern_var ; a symbol not in literals + | symbol ; a symbol in literals + | () + | (pattern . pattern) + | (ellipsis_pattern) + | #(pattern*) ; extends R4RS + | #(pattern* ellipsis_pattern) ; extends R4RS + | pattern_datum + +template @expansion{} pattern_var + | symbol + | () + | (template2 . template2) + | #(template*) ; extends R4RS + | pattern_datum + +template2 @expansion{} template + | ellipsis_template + +pattern_datum @expansion{} string ; no vector + | character + | boolean + | number + +ellipsis_pattern @expansion{} pattern ... + +ellipsis_template @expansion{} template ... + +pattern_var @expansion{} symbol ; not in literals + +literals @expansion{} () + | (symbol . literals) +@end example + +@subsection Definitions + +@table @asis + +@item Scope of an ellipsis +Within a pattern or template, the scope of an ellipsis (@code{...}) is +the pattern or template that appears to its left. + +@item Rank of a pattern variable +The rank of a pattern variable is the number of ellipses within whose +scope it appears in the pattern. + +@item Rank of a subtemplate +The rank of a subtemplate is the number of ellipses within whose scope +it appears in the template. + +@item Template rank of an occurrence of a pattern variable +The template rank of an occurrence of a pattern variable within a +template is the rank of that occurrence, viewed as a subtemplate. + +@item Variables bound by a pattern +The variables bound by a pattern are the pattern variables that appear +within it. + +@item Referenced variables of a subtemplate +The referenced variables of a subtemplate are the pattern variables that +appear within it. + +@item Variables opened by an ellipsis template +The variables opened by an ellipsis template are the referenced pattern +variables whose rank is greater than the rank of the ellipsis template. + +@end table + +@subsection Restrictions + +No pattern variable appears more than once within a pattern. + +For every occurrence of a pattern variable within a template, the +template rank of the occurrence must be greater than or equal to the +pattern variable's rank. + +Every ellipsis template must open at least one variable. + +For every ellipsis template, the variables opened by an ellipsis +template must all be bound to sequences of the same length. + +The compiled form of a @var{rule} is + +@example +rule @expansion{} (pattern template inserted) + +pattern @expansion{} pattern_var + | symbol + | () + | (pattern . pattern) + | ellipsis_pattern + | #(pattern) + | pattern_datum + +template @expansion{} pattern_var + | symbol + | () + | (template2 . template2) + | #(pattern) + | pattern_datum + +template2 @expansion{} template + | ellipsis_template + +pattern_datum @expansion{} string + | character + | boolean + | number + +pattern_var @expansion{} #(V symbol rank) + +ellipsis_pattern @expansion{} #(E pattern pattern_vars) + +ellipsis_template @expansion{} #(E template pattern_vars) + +inserted @expansion{} () + | (symbol . inserted) + +pattern_vars @expansion{} () + | (pattern_var . pattern_vars) + +rank @expansion{} exact non-negative integer +@end example + +where V and E are unforgeable values. + +The pattern variables associated with an ellipsis pattern are the +variables bound by the pattern, and the pattern variables associated +with an ellipsis template are the variables opened by the ellipsis +template. + +If the template contains a big chunk that contains no pattern variables +or inserted identifiers, then the big chunk will be copied +unnecessarily. That shouldn't matter very often. + + + + + +@node Syntactic Closures, Syntax-Case Macros, Macros That Work, Macros +@section Syntactic Closures + +@code{(require 'syntactic-closures)} + +@defun macro:expand expression +@defunx synclo:expand expression +Returns scheme code with the macros and derived expression types of +@var{expression} expanded to primitive expression types.@refill +@end defun + +@defun macro:eval expression +@defunx synclo:eval expression +@code{macro:eval} returns the value of @var{expression} in the current +top level environment. @var{expression} can contain macro definitions. +Side effects of @var{expression} will affect the top level +environment.@refill +@end defun + +@deffn Procedure macro:load filename +@deffnx Procedure synclo:load filename +@var{filename} should be a string. If filename names an existing file, +the @code{macro:load} procedure reads Scheme source code expressions and +definitions from the file and evaluates them sequentially. These +source code expressions and definitions may contain macro definitions. +The @code{macro:load} procedure does not affect the values returned by +@code{current-input-port} and @code{current-output-port}.@refill +@end deffn + +@subsection Syntactic Closure Macro Facility + +@center A Syntactic Closures Macro Facility +@center by Chris Hanson +@center 9 November 1991 + +This document describes @dfn{syntactic closures}, a low-level macro +facility for the Scheme programming language. The facility is an +alternative to the low-level macro facility described in the +@cite{Revised^4 Report on Scheme.} This document is an addendum to that +report. + +The syntactic closures facility extends the BNF rule for +@var{transformer spec} to allow a new keyword that introduces a +low-level macro transformer:@refill +@example +@var{transformer spec} := (transformer @var{expression}) +@end example + +Additionally, the following procedures are added: +@lisp +make-syntactic-closure +capture-syntactic-environment +identifier? +identifier=? +@end lisp + +The description of the facility is divided into three parts. The first +part defines basic terminology. The second part describes how macro +transformers are defined. The third part describes the use of +@dfn{identifiers}, which extend the syntactic closure mechanism to be +compatible with @code{syntax-rules}.@refill + +@subsubsection Terminology + +This section defines the concepts and data types used by the syntactic +closures facility. + +@itemize + +@item @dfn{Forms} are the syntactic entities out of which programs are +recursively constructed. A form is any expression, any definition, any +syntactic keyword, or any syntactic closure. The variable name that +appears in a @code{set!} special form is also a form. Examples of +forms:@refill +@lisp +17 +#t +car +(+ x 4) +(lambda (x) x) +(define pi 3.14159) +if +define +@end lisp + +@item An @dfn{alias} is an alternate name for a given symbol. It can +appear anywhere in a form that the symbol could be used, and when quoted +it is replaced by the symbol; however, it does not satisfy the predicate +@code{symbol?}. Macro transformers rarely distinguish symbols from +aliases, referring to both as identifiers.@refill + +@item A @dfn{syntactic} environment maps identifiers to their +meanings. More precisely, it determines whether an identifier is a +syntactic keyword or a variable. If it is a keyword, the meaning is an +interpretation for the form in which that keyword appears. If it is a +variable, the meaning identifies which binding of that variable is +referenced. In short, syntactic environments contain all of the +contextual information necessary for interpreting the meaning of a +particular form.@refill + +@item A @dfn{syntactic closure} consists of a form, a syntactic +environment, and a list of identifiers. All identifiers in the form +take their meaning from the syntactic environment, except those in the +given list. The identifiers in the list are to have their meanings +determined later. A syntactic closure may be used in any context in +which its form could have been used. Since a syntactic closure is also +a form, it may not be used in contexts where a form would be illegal. +For example, a form may not appear as a clause in the cond special form. +A syntactic closure appearing in a quoted structure is replaced by its +form.@refill + +@end itemize + +@subsubsection Transformer Definition + +This section describes the @code{transformer} special form and the +procedures @code{make-syntactic-closure} and +@code{capture-syntactic-environment}.@refill + +@deffn Syntax transformer expression + +Syntax: It is an error if this syntax occurs except as a +@var{transformer spec}.@refill + +Semantics: The @var{expression} is evaluated in the standard transformer +environment to yield a macro transformer as described below. This macro +transformer is bound to a macro keyword by the special form in which the +@code{transformer} expression appears (for example, +@code{let-syntax}).@refill + +A @dfn{macro transformer} is a procedure that takes two arguments, a +form and a syntactic environment, and returns a new form. The first +argument, the @dfn{input form}, is the form in which the macro keyword +occurred. The second argument, the @dfn{usage environment}, is the +syntactic environment in which the input form occurred. The result of +the transformer, the @dfn{output form}, is automatically closed in the +@dfn{transformer environment}, which is the syntactic environment in +which the @code{transformer} expression occurred.@refill + +For example, here is a definition of a push macro using +@code{syntax-rules}:@refill +@lisp +(define-syntax push + (syntax-rules () + ((push item list) + (set! list (cons item list))))) +@end lisp + +Here is an equivalent definition using @code{transformer}: +@lisp +(define-syntax push + (transformer + (lambda (exp env) + (let ((item + (make-syntactic-closure env '() (cadr exp))) + (list + (make-syntactic-closure env '() (caddr exp)))) + `(set! ,list (cons ,item ,list)))))) +@end lisp + +In this example, the identifiers @code{set!} and @code{cons} are closed +in the transformer environment, and thus will not be affected by the +meanings of those identifiers in the usage environment +@code{env}.@refill + +Some macros may be non-hygienic by design. For example, the following +defines a loop macro that implicitly binds @code{exit} to an escape +procedure. The binding of @code{exit} is intended to capture free +references to @code{exit} in the body of the loop, so @code{exit} must +be left free when the body is closed:@refill +@lisp +(define-syntax loop + (transformer + (lambda (exp env) + (let ((body (cdr exp))) + `(call-with-current-continuation + (lambda (exit) + (let f () + ,@@(map (lambda (exp) + (make-syntactic-closure env '(exit) + exp)) + body) + (f)))))))) +@end lisp + +To assign meanings to the identifiers in a form, use +@code{make-syntactic-closure} to close the form in a syntactic +environment.@refill +@end deffn + +@defun make-syntactic-closure environment free-names form + +@var{environment} must be a syntactic environment, @var{free-names} must +be a list of identifiers, and @var{form} must be a form. +@code{make-syntactic-closure} constructs and returns a syntactic closure +of @var{form} in @var{environment}, which can be used anywhere that +@var{form} could have been used. All the identifiers used in +@var{form}, except those explicitly excepted by @var{free-names}, obtain +their meanings from @var{environment}.@refill + +Here is an example where @var{free-names} is something other than the +empty list. It is instructive to compare the use of @var{free-names} in +this example with its use in the @code{loop} example above: the examples +are similar except for the source of the identifier being left +free.@refill +@lisp +(define-syntax let1 + (transformer + (lambda (exp env) + (let ((id (cadr exp)) + (init (caddr exp)) + (exp (cadddr exp))) + `((lambda (,id) + ,(make-syntactic-closure env (list id) exp)) + ,(make-syntactic-closure env '() init)))))) +@end lisp + +@code{let1} is a simplified version of @code{let} that only binds a +single identifier, and whose body consists of a single expression. When +the body expression is syntactically closed in its original syntactic +environment, the identifier that is to be bound by @code{let1} must be +left free, so that it can be properly captured by the @code{lambda} in +the output form.@refill + +To obtain a syntactic environment other than the usage environment, use +@code{capture-syntactic-environment}.@refill +@end defun + +@defun capture-syntactic-environment procedure + +@code{capture-syntactic-environment} returns a form that will, when +transformed, call @var{procedure} on the current syntactic environment. +@var{procedure} should compute and return a new form to be transformed, +in that same syntactic environment, in place of the form.@refill + +An example will make this clear. Suppose we wanted to define a simple +@code{loop-until} keyword equivalent to@refill +@lisp +(define-syntax loop-until + (syntax-rules () + ((loop-until id init test return step) + (letrec ((loop + (lambda (id) + (if test return (loop step))))) + (loop init))))) +@end lisp + +The following attempt at defining @code{loop-until} has a subtle bug: +@lisp +(define-syntax loop-until + (transformer + (lambda (exp env) + (let ((id (cadr exp)) + (init (caddr exp)) + (test (cadddr exp)) + (return (cadddr (cdr exp))) + (step (cadddr (cddr exp))) + (close + (lambda (exp free) + (make-syntactic-closure env free exp)))) + `(letrec ((loop + (lambda (,id) + (if ,(close test (list id)) + ,(close return (list id)) + (loop ,(close step (list id))))))) + (loop ,(close init '()))))))) +@end lisp + +This definition appears to take all of the proper precautions to prevent +unintended captures. It carefully closes the subexpressions in their +original syntactic environment and it leaves the @code{id} identifier +free in the @code{test}, @code{return}, and @code{step} expressions, so +that it will be captured by the binding introduced by the @code{lambda} +expression. Unfortunately it uses the identifiers @code{if} and +@code{loop} within that @code{lambda} expression, so if the user of +@code{loop-until} just happens to use, say, @code{if} for the +identifier, it will be inadvertently captured.@refill + +The syntactic environment that @code{if} and @code{loop} want to be +exposed to is the one just outside the @code{lambda} expression: before +the user's identifier is added to the syntactic environment, but after +the identifier loop has been added. +@code{capture-syntactic-environment} captures exactly that environment +as follows:@refill +@lisp +(define-syntax loop-until + (transformer + (lambda (exp env) + (let ((id (cadr exp)) + (init (caddr exp)) + (test (cadddr exp)) + (return (cadddr (cdr exp))) + (step (cadddr (cddr exp))) + (close + (lambda (exp free) + (make-syntactic-closure env free exp)))) + `(letrec ((loop + ,(capture-syntactic-environment + (lambda (env) + `(lambda (,id) + (,(make-syntactic-closure env '() `if) + ,(close test (list id)) + ,(close return (list id)) + (,(make-syntactic-closure env '() + `loop) + ,(close step (list id))))))))) + (loop ,(close init '()))))))) +@end lisp + +In this case, having captured the desired syntactic environment, it is +convenient to construct syntactic closures of the identifiers @code{if} +and the @code{loop} and use them in the body of the +@code{lambda}.@refill + +A common use of @code{capture-syntactic-environment} is to get the +transformer environment of a macro transformer:@refill +@lisp +(transformer + (lambda (exp env) + (capture-syntactic-environment + (lambda (transformer-env) + ...)))) +@end lisp +@end defun + +@subsubsection Identifiers + +This section describes the procedures that create and manipulate +identifiers. Previous syntactic closure proposals did not have an +identifier data type -- they just used symbols. The identifier data +type extends the syntactic closures facility to be compatible with the +high-level @code{syntax-rules} facility.@refill + +As discussed earlier, an identifier is either a symbol or an +@dfn{alias}. An alias is implemented as a syntactic closure whose +@dfn{form} is an identifier:@refill +@lisp +(make-syntactic-closure env '() 'a) + @result{} an @dfn{alias} +@end lisp + +Aliases are implemented as syntactic closures because they behave just +like syntactic closures most of the time. The difference is that an +alias may be bound to a new value (for example by @code{lambda} or +@code{let-syntax}); other syntactic closures may not be used this way. +If an alias is bound, then within the scope of that binding it is looked +up in the syntactic environment just like any other identifier.@refill + +Aliases are used in the implementation of the high-level facility +@code{syntax-rules}. A macro transformer created by @code{syntax-rules} +uses a template to generate its output form, substituting subforms of +the input form into the template. In a syntactic closures +implementation, all of the symbols in the template are replaced by +aliases closed in the transformer environment, while the output form +itself is closed in the usage environment. This guarantees that the +macro transformation is hygienic, without requiring the transformer to +know the syntactic roles of the substituted input subforms. + +@defun identifier? object +Returns @code{#t} if @var{object} is an identifier, otherwise returns +@code{#f}. Examples:@refill +@lisp +(identifier? 'a) + @result{} #t +(identifier? (make-syntactic-closure env '() 'a)) + @result{} #t +(identifier? "a") + @result{} #f +(identifier? #\a) + @result{} #f +(identifier? 97) + @result{} #f +(identifier? #f) + @result{} #f +(identifier? '(a)) + @result{} #f +(identifier? '#(a)) + @result{} #f +@end lisp + +The predicate @code{eq?} is used to determine if two identifers are +``the same''. Thus @code{eq?} can be used to compare identifiers +exactly as it would be used to compare symbols. Often, though, it is +useful to know whether two identifiers ``mean the same thing''. For +example, the @code{cond} macro uses the symbol @code{else} to identify +the final clause in the conditional. A macro transformer for +@code{cond} cannot just look for the symbol @code{else}, because the +@code{cond} form might be the output of another macro transformer that +replaced the symbol @code{else} with an alias. Instead the transformer +must look for an identifier that ``means the same thing'' in the usage +environment as the symbol @code{else} means in the transformer +environment.@refill +@end defun + +@defun identifier=? environment1 identifier1 environment2 identifier2 +@var{environment1} and @var{environment2} must be syntactic +environments, and @var{identifier1} and @var{identifier2} must be +identifiers. @code{identifier=?} returns @code{#t} if the meaning of +@var{identifier1} in @var{environment1} is the same as that of +@var{identifier2} in @var{environment2}, otherwise it returns @code{#f}. +Examples:@refill + +@lisp +(let-syntax + ((foo + (transformer + (lambda (form env) + (capture-syntactic-environment + (lambda (transformer-env) + (identifier=? transformer-env 'x env 'x))))))) + (list (foo) + (let ((x 3)) + (foo)))) + @result{} (#t #f) +@end lisp + +@lisp +(let-syntax ((bar foo)) + (let-syntax + ((foo + (transformer + (lambda (form env) + (capture-syntactic-environment + (lambda (transformer-env) + (identifier=? transformer-env 'foo + env (cadr form)))))))) + (list (foo foo) + (foobar)))) + @result{} (#f #t) +@end lisp +@end defun + +@subsubsection Acknowledgements + +The syntactic closures facility was invented by Alan Bawden and Jonathan +Rees. The use of aliases to implement @code{syntax-rules} was invented +by Alan Bawden (who prefers to call them @dfn{synthetic names}). Much +of this proposal is derived from an earlier proposal by Alan +Bawden.@refill + + + + + +@node Syntax-Case Macros, Fluid-Let, Syntactic Closures, Macros +@section Syntax-Case Macros + +@code{(require 'syntax-case)} + +@defun macro:expand expression +@defunx syncase:expand expression +Returns scheme code with the macros and derived expression types of +@var{expression} expanded to primitive expression types.@refill +@end defun + +@defun macro:eval expression +@defunx syncase:eval expression +@code{macro:eval} returns the value of @var{expression} in the current +top level environment. @var{expression} can contain macro definitions. +Side effects of @var{expression} will affect the top level +environment.@refill +@end defun + +@deffn Procedure macro:load filename +@deffnx Procedure syncase:load filename +@var{filename} should be a string. If filename names an existing file, +the @code{macro:load} procedure reads Scheme source code expressions and +definitions from the file and evaluates them sequentially. These +source code expressions and definitions may contain macro definitions. +The @code{macro:load} procedure does not affect the values returned by +@code{current-input-port} and @code{current-output-port}.@refill +@end deffn + +This is version 2.1 of @code{syntax-case}, the low-level macro facility +proposed and implemented by Robert Hieb and R. Kent Dybvig. + +This version is further adapted by Harald Hanche-Olsen + to make it compatible with, and easily usable +with, SLIB. Mainly, these adaptations consisted of: + +@itemize @bullet +@item +Removing white space from @file{expand.pp} to save space in the +distribution. This file is not meant for human readers anyway@dots{} + +@item +Removed a couple of Chez scheme dependencies. + +@item +Renamed global variables used to minimize the possibility of name +conflicts. + +@item +Adding an SLIB-specific initialization file. + +@item +Removing a couple extra files, most notably the documentation (but see +below). +@end itemize + +If you wish, you can see exactly what changes were done by reading the +shell script in the file @file{syncase.sh}. + +The two PostScript files were omitted in order to not burden the SLIB +distribution with them. If you do intend to use @code{syntax-case}, +however, you should get these files and print them out on a PostScript +printer. They are available with the original @code{syntax-case} +distribution by anonymous FTP in +@file{cs.indiana.edu:/pub/scheme/syntax-case}.@refill + +In order to use syntax-case from an interactive top level, execute: +@lisp +(require 'syntax-case) +(require 'repl) +(repl:top-level macro:eval) +@end lisp +See the section Repl (@xref{Repl}) for more information. + +To check operation of syntax-case get +@file{cs.indiana.edu:/pub/scheme/syntax-case}, and type +@lisp +(require 'syntax-case) +(syncase:sanity-check) +@end lisp + +Beware that @code{syntax-case} takes a long time to load -- about 20s on +a SPARCstation SLC (with SCM) and about 90s on a Macintosh SE/30 (with +Gambit). + +@subsection Notes + +All R4RS syntactic forms are defined, including @code{delay}. Along +with @code{delay} are simple definitions for @code{make-promise} (into +which @code{delay} expressions expand) and @code{force}.@refill + +@code{syntax-rules} and @code{with-syntax} (described in @cite{TR356}) +are defined.@refill + +@code{syntax-case} is actually defined as a macro that expands into +calls to the procedure @code{syntax-dispatch} and the core form +@code{syntax-lambda}; do not redefine these names.@refill + +Several other top-level bindings not documented in TR356 are created: +@itemize +@item the ``hooks'' in @file{hooks.ss} +@item the @code{build-} procedures in @file{output.ss} +@item @code{expand-syntax} (the expander) +@end itemize + +The syntax of define has been extended to allow @code{(define @var{id})}, +which assigns @var{id} to some unspecified value.@refill + +We have attempted to maintain R4RS compatibility where possible. The +incompatibilities should be confined to @file{hooks.ss}. Please let us +know if there is some incompatibility that is not flagged as such.@refill + +Send bug reports, comments, suggestions, and questions to Kent Dybvig +(dyb@@iuvax.cs.indiana.edu). + +@subsection Note from maintainer + +Included with the @code{syntax-case} files was @file{structure.scm} +which defines a macro @code{define-structure}. There is no +documentation for this macro and it is not used by any code in SLIB. + +@node Fluid-Let, Yasos, Syntax-Case Macros, Macros +@section Fluid-Let + +@code{(require 'fluid-let)} + +@deffn Syntax fluid-let @code{(@var{bindings} @dots{})} @var{forms}@dots{} +@end deffn +@lisp +(fluid-let ((@var{variable} @var{init}) @dots{}) + @var{expression} @var{expression} @dots{}) +@end lisp + +The @var{init}s are evaluated in the current environment (in some +unspecified order), the current values of the @var{variable}s are saved, +the results are assigned to the @var{variable}s, the @var{expression}s +are evaluated sequentially in the current environment, the +@var{variable}s are restored to their original values, and the value of +the last @var{expression} is returned.@refill + +The syntax of this special form is similar to that of @code{let}, but +@code{fluid-let} temporarily rebinds existing @var{variable}s. Unlike +@code{let}, @code{fluid-let} creates no new bindings; instead it +@emph{assigns} the values of each @var{init} to the binding (determined +by the rules of lexical scoping) of its corresponding +@var{variable}.@refill + + +@node Yasos, , Fluid-Let, Macros +@section Yasos + +@c Much of the documentation in this section was written by Dave Love +@c (d.love@dl.ac.uk) -- don't blame Ken Dickey for its faults. +@c but we can blame him for not writing it! + +@code{(require 'oop)} or @code{(require 'yasos)} + +`Yet Another Scheme Object System' is a simple object system for Scheme +based on the paper by Norman Adams and Jonathan Rees: @cite{Object +Oriented Programming in Scheme}, Proceedings of the 1988 ACM Conference +on LISP and Functional Programming, July 1988 [ACM #552880].@refill + +Another reference is: + +Ken Dickey. +@ifset html + +@end ifset +Scheming with Objects +@ifset html + +@end ifset +@cite{AI Expert} Volume 7, Number 10 (October 1992), pp. 24-33. + +@menu +* Yasos terms:: Definitions and disclaimer. +* Yasos interface:: The Yasos macros and procedures. +* Setters:: Dylan-like setters in Yasos. +* Yasos examples:: Usage of Yasos and setters. +@end menu + +@node Yasos terms, Yasos interface, Yasos, Yasos +@subsection Terms + +@table @asis +@item @dfn{Object} +Any Scheme data object. + +@item @dfn{Instance} +An instance of the OO system; an @dfn{object}. + +@item @dfn{Operation} +A @var{method}. +@end table + +@table @emph +@item Notes: +The object system supports multiple inheritance. An instance can +inherit from 0 or more ancestors. In the case of multiple inherited +operations with the same identity, the operation used is that from the +first ancestor which contains it (in the ancestor @code{let}). An +operation may be applied to any Scheme data object---not just instances. +As code which creates instances is just code, there are no @dfn{classes} +and no meta-@var{anything}. Method dispatch is by a procedure call a la +CLOS rather than by @code{send} syntax a la Smalltalk.@refill + +@item Disclaimer: +There are a number of optimizations which can be made. This +implementation is expository (although performance should be quite +reasonable). See the L&FP paper for some suggestions.@refill +@end table + + + + + +@node Yasos interface, Setters, Yasos terms, Yasos +@subsection Interface + +@deffn Syntax define-operation @code{(}opname self arg @dots{}@code{)} @var{default-body} +Defines a default behavior for data objects which don't handle the +operation @var{opname}. The default default behavior (for an empty +@var{default-body}) is to generate an error.@refill +@end deffn + +@deffn Syntax define-predicate opname? +Defines a predicate @var{opname?}, usually used for determining the +@dfn{type} of an object, such that @code{(@var{opname?} @var{object})} +returns @code{#t} if @var{object} has an operation @var{opname?} and +@code{#f} otherwise.@refill +@end deffn + +@deffn Syntax object @code{((@var{name} @var{self} @var{arg} @dots{}) @var{body})} @dots{} +Returns an object (an instance of the object system) with operations. +Invoking @code{(@var{name} @var{object} @var{arg} @dots{}} executes the +@var{body} of the @var{object} with @var{self} bound to @var{object} and +with argument(s) @var{arg}@dots{}.@refill +@end deffn + +@deffn Syntax object-with-ancestors @code{((}ancestor1 init1@code{)} @dots{}@code{)} operation @dots{} +A @code{let}-like form of @code{object} for multiple inheritance. It +returns an object inheriting the behaviour of @var{ancestor1} etc. An +operation will be invoked in an ancestor if the object itself does not +provide such a method. In the case of multiple inherited operations +with the same identity, the operation used is the one found in the first +ancestor in the ancestor list. +@end deffn + +@deffn Syntax operate-as component operation self arg @dots{} +Used in an operation definition (of @var{self}) to invoke the +@var{operation} in an ancestor @var{component} but maintain the object's +identity. Also known as ``send-to-super''.@refill +@end deffn + +@deffn Procedure print obj port +A default @code{print} operation is provided which is just @code{(format +@var{port} @var{obj})} (@xref{Format}) for non-instances and prints +@var{obj} preceded by @samp{#} for instances. +@end deffn + +@defun size obj +The default method returns the number of elements in @var{obj} if it is +a vector, string or list, @code{2} for a pair, @code{1} for a character +and by default id an error otherwise. Objects such as collections +(@xref{Collections}) may override the default in an obvious way.@refill +@end defun + + + + + +@node Setters, Yasos examples, Yasos interface, Yasos +@subsection Setters + +@dfn{Setters} implement @dfn{generalized locations} for objects +associated with some sort of mutable state. A @dfn{getter} operation +retrieves a value from a generalized location and the corresponding +setter operation stores a value into the location. Only the getter is +named -- the setter is specified by a procedure call as below. (Dylan +uses special syntax.) Typically, but not necessarily, getters are +access operations to extract values from Yasos objects (@xref{Yasos}). +Several setters are predefined, corresponding to getters @code{car}, +@code{cdr}, @code{string-ref} and @code{vector-ref} e.g., @code{(setter +car)} is equivalent to @code{set-car!}. + +This implementation of setters is similar to that in Dylan(TM) +(@cite{Dylan: An object-oriented dynamic language}, Apple Computer +Eastern Research and Technology). Common LISP provides similar +facilities through @code{setf}. + +@defun setter getter +Returns the setter for the procedure @var{getter}. E.g., since +@code{string-ref} is the getter corresponding to a setter which is +actually @code{string-set!}: +@example +(define foo "foo") +((setter string-ref) foo 0 #\F) ; set element 0 of foo +foo @result{} "Foo" +@end example +@end defun + +@deffn Syntax set place new-value +If @var{place} is a variable name, @code{set} is equivalent to +@code{set!}. Otherwise, @var{place} must have the form of a procedure +call, where the procedure name refers to a getter and the call indicates +an accessible generalized location, i.e., the call would return a value. +The return value of @code{set} is usually unspecified unless used with a +setter whose definition guarantees to return a useful value. +@example +(set (string-ref foo 2) #\O) ; generalized location with getter +foo @result{} "FoO" +(set foo "foo") ; like set! +foo @result{} "foo" +@end example +@end deffn + +@deffn Procedure add-setter getter setter +Add procedures @var{getter} and @var{setter} to the (inaccessible) list +of valid setter/getter pairs. @var{setter} implements the store +operation corresponding to the @var{getter} access operation for the +relevant state. The return value is unspecified. +@end deffn + +@deffn Procedure remove-setter-for getter +Removes the setter corresponding to the specified @var{getter} from the +list of valid setters. The return value is unspecified. +@end deffn + +@deffn Syntax define-access-operation getter-name +Shorthand for a Yasos @code{define-operation} defining an operation +@var{getter-name} that objects may support to return the value of some +mutable state. The default operation is to signal an error. The return +value is unspecified. +@end deffn + + + + + +@node Yasos examples, , Setters, Yasos +@subsection Examples + +@lisp +(define-operation (print obj port) + (format port + (if (instance? obj) "#" "~s") + obj)) + +(define-operation (SIZE obj) + (cond + ((vector? obj) (vector-length obj)) + ((list? obj) (length obj)) + ((pair? obj) 2) + ((string? obj) (string-length obj)) + ((char? obj) 1) + (else + (error "Operation not supported: size" obj)))) + +(define-predicate cell?) +(define-operation (fetch obj)) +(define-operation (store! obj newValue)) + +(define (make-cell value) + (object + ((cell? self) #t) + ((fetch self) value) + ((store! self newValue) + (set! value newValue) + newValue) + ((size self) 1) + ((print self port) + (format port "#" (fetch self))))) + +(define-operation (discard obj value) + (format #t "Discarding ~s~%" value)) + +(define (make-filtered-cell value filter) + (object-with-ancestors ((cell (make-cell value))) + ((store! self newValue) + (if (filter newValue) + (store! cell newValue) + (discard self newValue))))) + +(define-predicate array?) +(define-operation (array-ref array index)) +(define-operation (array-set! array index value)) + +(define (make-array num-slots) + (let ((anArray (make-vector num-slots))) + (object + ((array? self) #t) + ((size self) num-slots) + ((array-ref self index) (vector-ref anArray index)) + ((array-set! self index newValue) (vector-set! anArray index newValue)) + ((print self port) (format port "#" (size self)))))) + +(define-operation (position obj)) +(define-operation (discarded-value obj)) + +(define (make-cell-with-history value filter size) + (let ((pos 0) (most-recent-discard #f)) + (object-with-ancestors + ((cell (make-filtered-call value filter)) + (sequence (make-array size))) + ((array? self) #f) + ((position self) pos) + ((store! self newValue) + (operate-as cell store! self newValue) + (array-set! self pos newValue) + (set! pos (+ pos 1))) + ((discard self value) + (set! most-recent-discard value)) + ((discarded-value self) most-recent-discard) + ((print self port) + (format port "#" (fetch self)))))) + +(define-access-operation fetch) +(add-setter fetch store!) +(define foo (make-cell 1)) +(print foo #f) +@result{} "#" +(set (fetch foo) 2) +@result{} +(print foo #f) +@result{} "#" +(fetch foo) +@result{} 2 +@end lisp + +@node Numerics, Procedures, Macros, Top +@chapter Numerics + +@menu +* Bit-Twiddling:: 'logical +* Modular Arithmetic:: 'modular +* Prime Testing and Generation:: 'primes +* Prime Factorization:: 'factor +* Random Numbers:: 'random +* Cyclic Checksum:: 'make-crc +* Plotting:: 'charplot +* Root Finding:: +@end menu + + +@node Bit-Twiddling, Modular Arithmetic, Numerics, Numerics +@section Bit-Twiddling + +@code{(require 'logical)} + +The bit-twiddling functions are made available through the use of the +@code{logical} package. @code{logical} is loaded by inserting +@code{(require 'logical)} before the code that uses these +functions.@refill + +@defun logand n1 n1 +Returns the integer which is the bit-wise AND of the two integer +arguments. + +Example: +@lisp +(number->string (logand #b1100 #b1010) 2) + @result{} "1000" +@end lisp +@end defun + +@defun logior n1 n2 +Returns the integer which is the bit-wise OR of the two integer +arguments. + +Example: +@lisp +(number->string (logior #b1100 #b1010) 2) + @result{} "1110" +@end lisp +@end defun + +@defun logxor n1 n2 +Returns the integer which is the bit-wise XOR of the two integer +arguments. + +Example: +@lisp +(number->string (logxor #b1100 #b1010) 2) + @result{} "110" +@end lisp +@end defun + +@defun lognot n +Returns the integer which is the 2s-complement of the integer argument. + +Example: +@lisp +(number->string (lognot #b10000000) 2) + @result{} "-10000001" +(number->string (lognot #b0) 2) + @result{} "-1" +@end lisp +@end defun + +@defun logtest j k +@example +(logtest j k) @equiv{} (not (zero? (logand j k))) + +(logtest #b0100 #b1011) @result{} #f +(logtest #b0100 #b0111) @result{} #t +@end example +@end defun + +@defun logbit? index j +@example +(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j) + +(logbit? 0 #b1101) @result{} #t +(logbit? 1 #b1101) @result{} #f +(logbit? 2 #b1101) @result{} #t +(logbit? 3 #b1101) @result{} #t +(logbit? 4 #b1101) @result{} #f +@end example +@end defun + +@defun ash int count +Returns an integer equivalent to +@code{(inexact->exact (floor (* @var{int} (expt 2 @var{count}))))}.@refill + +Example: +@lisp +(number->string (ash #b1 3) 2) + @result{} "1000" +(number->string (ash #b1010 -1) 2) + @result{} "101" +@end lisp +@end defun + +@defun logcount n +Returns the number of bits in integer @var{n}. If integer is positive, +the 1-bits in its binary representation are counted. If negative, the +0-bits in its two's-complement binary representation are counted. If 0, +0 is returned. + +Example: +@lisp +(logcount #b10101010) + @result{} 4 +(logcount 0) + @result{} 0 +(logcount -2) + @result{} 1 +@end lisp +@end defun + +@defun integer-length n +Returns the number of bits neccessary to represent @var{n}. + +Example: +@lisp +(integer-length #b10101010) + @result{} 8 +(integer-length 0) + @result{} 0 +(integer-length #b1111) + @result{} 4 +@end lisp +@end defun + +@defun integer-expt n k +Returns @var{n} raised to the non-negative integer exponent @var{k}. + +Example: +@lisp +(integer-expt 2 5) + @result{} 32 +(integer-expt -3 3) + @result{} -27 +@end lisp +@end defun + +@defun bit-extract n start end +Returns the integer composed of the @var{start} (inclusive) through +@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes +the 0-th bit in the result.@refill + +Example: +@lisp +(number->string (bit-extract #b1101101010 0 4) 2) + @result{} "1010" +(number->string (bit-extract #b1101101010 4 9) 2) + @result{} "10110" +@end lisp +@end defun + + +@node Modular Arithmetic, Prime Testing and Generation, Bit-Twiddling, Numerics +@section Modular Arithmetic + +@code{(require 'modular)} + +@defun extended-euclid n1 n2 +Returns a list of 3 integers @code{(d x y)} such that d = gcd(@var{n1}, +@var{n2}) = @var{n1} * x + @var{n2} * y.@refill +@end defun + +@defun symmetric:modulus n +Returns @code{(quotient (+ -1 n) -2)} for positive odd integer @var{n}. +@end defun + +@defun modulus->integer modulus +Returns the non-negative integer characteristic of the ring formed when +@var{modulus} is used with @code{modular:} procedures. +@end defun + +@defun modular:normalize modulus n +Returns the integer @code{(modulo @var{n} (modulus->integer +@var{modulus}))} in the representation specified by @var{modulus}. +@end defun + +@noindent +The rest of these functions assume normalized arguments; That is, the +arguments are constrained by the following table: + +@noindent +For all of these functions, if the first argument (@var{modulus}) is: +@table @code +@item positive? +Work as before. The result is between 0 and @var{modulus}. + +@item zero? +The arguments are treated as integers. An integer is returned. + +@item negative? +The arguments and result are treated as members of the integers modulo +@code{(+ 1 (* -2 @var{modulus}))}, but with @dfn{symmetric} +representation; i.e. @code{(<= (- @var{modulus}) @var{n} +@var{modulus})}. +@end table + +@noindent +If all the arguments are fixnums the computation will use only fixnums. + +@defun modular:invertable? modulus k +Returns @code{#t} if there exists an integer n such that @var{k} * n +@equiv{} 1 mod @var{modulus}, and @code{#f} otherwise. +@end defun + +@defun modular:invert modulus k2 +Returns an integer n such that 1 = (n * @var{k2}) mod @var{modulus}. If +@var{k2} has no inverse mod @var{modulus} an error is signaled. +@end defun + +@defun modular:negate modulus k2 +Returns (@minus{}@var{k2}) mod @var{modulus}. +@end defun + +@defun modular:+ modulus k2 k3 +Returns (@var{k2} + @var{k3}) mod @var{modulus}. +@end defun + +@defun modular:@minus{} modulus k2 k3 +Returns (@var{k2} @minus{} @var{k3}) mod @var{modulus}. +@end defun + +@defun modular:* modulus k2 k3 +Returns (@var{k2} * @var{k3}) mod @var{modulus}. + +The Scheme code for @code{modular:*} with negative @var{modulus} is not +completed for fixnum-only implementations. +@end defun + +@defun modular:expt modulus k2 k3 +Returns (@var{k2} ^ @var{k3}) mod @var{modulus}. +@end defun + + +@node Prime Testing and Generation, Prime Factorization, Modular Arithmetic, Numerics +@section Prime Testing and Generation + +@code{(require 'primes)} + +This package tests and generates prime numbers. The strategy used is +as follows: + +@itemize +@item +First, use trial division by small primes (primes less than 1000) to +quickly weed out composites with small factors. As a side benefit, this +makes the test precise for numbers up to one million. +@item +Second, apply the Miller-Rabin primality test to detect (with high +probability) any remaining composites. +@end itemize + +The Miller-Rabin test is a Monte-Carlo test---in other words, it's fast +and it gets the right answer with high probability. For a candidate +that @emph{is} prime, the Miller-Rabin test is certain to report +"prime"; it will never report "composite". However, for a candidate +that is composite, there is a (small) probability that the Miller-Rabin +test will erroneously report "prime". This probability can be made +arbitarily small by adjusting the number of iterations of the +Miller-Rabin test. + +@defun probably-prime? candidate +@defunx probably-prime? candidate iter +Returns @code{#t} if @code{candidate} is probably prime. The optional +parameter @code{iter} controls the number of iterations of the +Miller-Rabin test. The probability of a composite candidate being +mistaken for a prime is at most @code{(1/4)^iter}. The default value of +@code{iter} is 15, which makes the probability less than 1 in 10^9. + +@end defun + +@defun primes< start count +@defunx primes< start count iter +@defunx primes> start count +@defunx primes> start count iter +Returns a list of the first @code{count} odd probable primes less (more) +than or equal to @code{start}. The optional parameter @code{iter} +controls the number of iterations of the Miller-Rabin test for each +candidate. The probability of a composite candidate being mistaken for +a prime is at most @code{(1/4)^iter}. The default value of @code{iter} +is 15, which makes the probability less than 1 in 10^9. + +@end defun + +@menu +* The Miller-Rabin Test:: How the Miller-Rabin test works +@end menu + +@node The Miller-Rabin Test, , Prime Testing and Generation, Prime Testing and Generation +@subsection Theory + +Rabin and Miller's result can be summarized as follows. Let @code{p} +(the candidate prime) be any odd integer greater than 2. Let @code{b} +(the "base") be an integer in the range @code{2 ... p-1}. There is a +fairly simple Boolean function---call it @code{C}, for +"Composite"---with the following properties: +@itemize + +@item +If @code{p} is prime, @code{C(p, b)} is false for all @code{b} in the range +@code{2 ... p-1}. + +@item +If @code{p} is composite, @code{C(p, b)} is false for at most 1/4 of all +@code{b} in the range @code{ 2 ... p-1}. (If the test fails for base +@code{b}, @code{p} is called a @emph{strong pseudo-prime to base +@code{b}}.) + +@end itemize +For details of @code{C}, and why it fails for at most 1/4 of the +potential bases, please consult a book on number theory or cryptography +such as "A Course in Number Theory and Cryptography" by Neal Koblitz, +published by Springer-Verlag 1994. + +There is nothing probablistic about this result. It's true for all +@code{p}. If we had time to test @code{(1/4)p + 1} different bases, we +could definitively determine the primality of @code{p}. For large +candidates, that would take much too long---much longer than the simple +approach of dividing by all numbers up to @code{sqrt(p)}. This is +where probability enters the picture. + +Suppose we have some candidate prime @code{p}. Pick a random integer +@code{b} in the range @code{2 ... p-1}. Compute @code{C(p,b)}. If +@code{p} is prime, the result will certainly be false. If @code{p} is +composite, the probability is at most 1/4 that the result will be false +(demonstrating that @code{p} is a strong pseudoprime to base @code{b}). +The test can be repeated with other random bases. If @code{p} is prime, +each test is certain to return false. If @code{p} is composite, the +probability of @code{C(p,b)} returning false is at most 1/4 for each +test. Since the @code{b} are chosen at random, the tests outcomes are +independent. So if @code{p} is composite and the test is repeated, say, +15 times, the probability of it returning false all fifteen times is at +most (1/4)^15, or about 10^-9. If the test is repeated 30 times, the +probability of failure drops to at most 8.3e-25. + +Rabin and Miller's result holds for @emph{all} candidates @code{p}. +However, if the candidate @code{p} is picked at random, the probability +of the Miller-Rabin test failing is much less than the computed bound. +This is because, for @emph{most} composite numbers, the fraction of +bases that cause the test to fail is much less than 1/4. For example, +if you pick a random odd number less than 1000 and apply the +Miller-Rabin test with only 3 random bases, the computed failure bound +is (1/4)^3, or about 1.6e-2. However, the actual probability of failure +is much less---about 7.2e-5. If you accidentally pick 703 to test for +primality, the probability of failure is (161/703)^3, or about 1.2e-2, +which is almost as high as the computed bound. This is because 703 is a +strong pseudoprime to 161 bases. But if you pick at random there is +only a small chance of picking 703, and no other number less than 1000 +has that high a percentage of pseudoprime bases. + +The Miller-Rabin test is sometimes used in a slightly different fashion, +where it can, at least in principle, cause problems. The weaker version +uses small prime bases instead of random bases. If you are picking +candidates at random and testing for primality, this works well since +very few composites are strong pseudo-primes to small prime bases. (For +example, there is only one composite less than 2.5e10 that is a strong +pseudo-prime to the bases 2, 3, 5, and 7.) The problem with this +approach is that once a candidate has been picked, the test is +deterministic. This distinction is subtle, but real. With the +randomized test, for @emph{any} candidate you pick---even if your +candidate-picking procedure is strongly biased towards troublesome +numbers, the test will work with high probability. With the +deterministic version, for any particular candidate, the test will +either work (with probability 1), or fail (with probability 1). It +won't fail for very many candidates, but that won't be much consolation +if your candidate-picking procedure is somehow biased toward troublesome +numbers. + + +@node Prime Factorization, Random Numbers, Prime Testing and Generation, Numerics +@section Prime Factorization + +@code{(require 'factor)} + + +@defun factor k +Returns a list of the prime factors of @var{k}. The order of the +factors is unspecified. In order to obtain a sorted list do +@code{(sort! (factor k) <)}.@refill +@end defun + +@emph{Note:} The rest of these procedures implement the Solovay-Strassen +primality test. This test has been superseeded by the faster +@xref{Prime Testing and Generation, probably-prime?}. However these are +left here as they take up little space and may be of use to an +implementation without bignums. + +See Robert Solovay and Volker Strassen, @cite{A Fast Monte-Carlo Test +for Primality}, SIAM Journal on Computing, 1977, pp 84-85. + +@defun jacobi-symbol p q +Returns the value (+1, @minus{}1, or 0) of the Jacobi-Symbol of exact +non-negative integer @var{p} and exact positive odd integer +@var{q}.@refill +@end defun + +@defun prime? p +Returns @code{#f} if @var{p} is composite; @code{#t} if @var{p} is +prime. There is a slight chance @code{(expt 2 (- prime:trials))} that a +composite will return @code{#t}.@refill +@end defun + +@defun prime:trials +Is the maxinum number of iterations of Solovay-Strassen that will be +done to test a number for primality. +@end defun + + + +@node Random Numbers, Cyclic Checksum, Prime Factorization, Numerics +@section Random Numbers + +@code{(require 'random)} + + +@deffn Procedure random n +@deffnx Procedure random n state +Accepts a positive integer or real @var{n} and returns a number of the +same type between zero (inclusive) and @var{n} (exclusive). The values +returned have a uniform distribution.@refill + +The optional argument @var{state} must be of the type produced by +@code{(make-random-state)}. It defaults to the value of the variable +@code{*random-state*}. This object is used to maintain the state of the +pseudo-random-number generator and is altered as a side effect of the +@code{random} operation.@refill +@end deffn + +@defvar *random-state* +Holds a data structure that encodes the internal state of the +random-number generator that @code{random} uses by default. The nature +of this data structure is implementation-dependent. It may be printed +out and successfully read back in, but may or may not function correctly +as a random-number state object in another implementation.@refill +@end defvar + +@deffn Procedure make-random-state +@deffnx Procedure make-random-state state +Returns a new object of type suitable for use as the value of the +variable @code{*random-state*} and as a second argument to +@code{random}. If argument @var{state} is given, a copy of it is +returned. Otherwise a copy of @code{*random-state*} is returned.@refill +@end deffn + +If inexact numbers are support by the Scheme implementation, +@file{randinex.scm} will be loaded as well. @file{randinex.scm} +contains procedures for generating inexact distributions.@refill + +@deffn Procedure random:uniform state +Returns an uniformly distributed inexact real random number in the +range between 0 and 1. +@end deffn + +@deffn Procedure random:solid-sphere! vect +@deffnx Procedure random:solid-sphere! vect state +Fills @var{vect} with inexact real random numbers the sum of whose +squares is less than 1.0. Thinking of @var{vect} as coordinates in +space of dimension @var{n} = @code{(vector-length @var{vect})}, the +coordinates are uniformly distributed within the unit @var{n}-shere. +The sum of the squares of the numbers is returned.@refill +@end deffn + +@deffn Procedure random:hollow-sphere! vect +@deffnx Procedure random:hollow-sphere! vect state +Fills @var{vect} with inexact real random numbers the sum of whose +squares is equal to 1.0. Thinking of @var{vect} as coordinates in space +of dimension n = @code{(vector-length @var{vect})}, the coordinates are +uniformly distributed over the surface of the unit n-shere.@refill +@end deffn + +@deffn Procedure random:normal +@deffnx Procedure random:normal state +Returns an inexact real in a normal distribution with mean 0 and +standard deviation 1. For a normal distribution with mean @var{m} and +standard deviation @var{d} use @code{(+ @var{m} (* @var{d} +(random:normal)))}.@refill +@end deffn + +@deffn Procedure random:normal-vector! vect +@deffnx Procedure random:normal-vector! vect state +Fills @var{vect} with inexact real random numbers which are independent +and standard normally distributed (i.e., with mean 0 and variance 1). +@end deffn + +@deffn Procedure random:exp +@deffnx Procedure random:exp state +Returns an inexact real in an exponential distribution with mean 1. For +an exponential distribution with mean @var{u} use (* @var{u} +(random:exp)).@refill +@end deffn + + +@node Cyclic Checksum, Plotting, Random Numbers, Numerics +@section Cyclic Checksum + +@code{(require 'make-crc)} + +@defun make-port-crc +@defunx make-port-crc degree +@defunx make-port-crc degree generator +Returns an expression for a procedure of one argument, a port. This +procedure reads characters from the port until the end of file and +returns the integer checksum of the bytes read. + +The integer @var{degree}, if given, specifies the degree of the +polynomial being computed -- which is also the number of bits computed +in the checksums. The default value is 32. + +The integer @var{generator} specifies the polynomial being computed. +The power of 2 generating each 1 bit is the exponent of a term of the +polynomial. The bit at position @var{degree} is implicit and should not +be part of @var{generator}. This allows systems with numbers limited to +32 bits to calculate 32 bit checksums. The default value of +@var{generator} when @var{degree} is 32 (its default) is: + +@example +(make-port-crc 32 #b00000100110000010001110110110111) +@end example + +Creates a procedure to calculate the P1003.2/D11.2 (POSIX.2) 32-bit +checksum from the polynomial: + +@example + 32 26 23 22 16 12 11 + ( x + x + x + x + x + x + x + + + 10 8 7 5 4 2 1 + x + x + x + x + x + x + x + 1 ) mod 2 +@end example +@end defun + +@example +(require 'make-crc) +(define crc32 (slib:eval (make-port-crc))) +(define (file-check-sum file) (call-with-input-file file crc32)) +(file-check-sum (in-vicinity (library-vicinity) "ratize.scm")) + +@result{} 3553047446 +@end example + +@node Plotting, Root Finding, Cyclic Checksum, Numerics +@section Plotting on Character Devices + +@code{(require 'charplot)} + +The plotting procedure is made available through the use of the +@code{charplot} package. @code{charplot} is loaded by inserting +@code{(require 'charplot)} before the code that uses this +procedure.@refill + +@defvar charplot:height +The number of rows to make the plot vertically. +@end defvar + +@defvar charplot:width +The number of columns to make the plot horizontally. +@end defvar + +@deffn Procedure plot! coords x-label y-label +@var{coords} is a list of pairs of x and y coordinates. @var{x-label} +and @var{y-label} are strings with which to label the x and y +axes.@refill + +Example: +@example +(require 'charplot) +(set! charplot:height 19) +(set! charplot:width 45) + +(define (make-points n) + (if (zero? n) + '() + (cons (cons (/ n 6) (sin (/ n 6))) (make-points (1- n))))) + +(plot! (make-points 37) "x" "Sin(x)") +@print{} +@group + Sin(x) ______________________________________________ + 1.25|- | + | | + 1|- **** | + | ** ** | + 750.0e-3|- * * | + | * * | + 500.0e-3|- * * | + | * | + 250.0e-3|- * | + | * * | + 0|-------------------*--------------------------| + | * | + -250.0e-3|- * * | + | * * | + -500.0e-3|- * | + | * * | + -750.0e-3|- * * | + | ** ** | + -1|- **** | + |____________:_____._____:_____._____:_________| + x 2 4 +@end group +@end example +@end deffn + + +@node Root Finding, , Plotting, Numerics +@section Root Finding + +@code{(require 'root)} + +@defun newtown:find-integer-root f df/dx x0 +Given integer valued procedure @var{f}, its derivative (with respect to +its argument) @var{df/dx}, and initial integer value @var{x0} for which +@var{df/dx}(@var{x0}) is non-zero, returns an integer @var{x} for which +@var{f}(@var{x}) is closer to zero than either of the integers adjacent +to @var{x}; or returns @code{#f} if such an integer can't be found. + +To find the closest integer to a given integers square root: + +@example +(define (integer-sqrt y) + (newton:find-integer-root + (lambda (x) (- (* x x) y)) + (lambda (x) (* 2 x)) + (ash 1 (quotient (integer-length y) 2)))) + +(integer-sqrt 15) @result{} 4 +@end example +@end defun + +@defun integer-sqrt y +Given a non-negative integer @var{y}, returns the rounded square-root of +@var{y}. +@end defun + +@defun newton:find-root f df/dx x0 prec +Given real valued procedures @var{f}, @var{df/dx} of one (real) +argument, initial real value @var{x0} for which @var{df/dx}(@var{x0}) is +non-zero, and positive real number @var{prec}, returns a real @var{x} +for which @code{abs}(@var{f}(@var{x})) is less than @var{prec}; or +returns @code{#f} if such a real can't be found. + +If @code{prec} is instead a negative integer, @code{newton:find-root} +returns the result of -@var{prec} iterations. +@end defun + +@noindent +H. J. Orchard, @cite{The Laguerre Method for Finding the Zeros of +Polynomials}, IEEE Transactions on Circuits and Systems, Vol. 36, +No. 11, November 1989, pp 1377-1381. + +@quotation +There are 2 errors in Orchard's Table II. Line k=2 for starting +value of 1000+j0 should have Z_k of 1.0475 + j4.1036 and line k=2 +for starting value of 0+j1000 should have Z_k of 1.0988 + j4.0833. +@end quotation + + +@defun laguerre:find-root f df/dz ddf/dz^2 z0 prec +Given complex valued procedure @var{f} of one (complex) argument, its +derivative (with respect to its argument) @var{df/dx}, its second +derivative @var{ddf/dz^2}, initial complex value @var{z0}, and positive +real number @var{prec}, returns a complex number @var{z} for which +@code{magnitude}(@var{f}(@var{z})) is less than @var{prec}; or returns +@code{#f} if such a number can't be found. + +If @code{prec} is instead a negative integer, @code{laguerre:find-root} +returns the result of -@var{prec} iterations. +@end defun + +@defun laguerre:find-polynomial-root deg f df/dz ddf/dz^2 z0 prec +Given polynomial procedure @var{f} of integer degree @var{deg} of one +argument, its derivative (with respect to its argument) @var{df/dx}, its +second derivative @var{ddf/dz^2}, initial complex value @var{z0}, and +positive real number @var{prec}, returns a complex number @var{z} for +which @code{magnitude}(@var{f}(@var{z})) is less than @var{prec}; or +returns @code{#f} if such a number can't be found. + +If @code{prec} is instead a negative integer, +@code{laguerre:find-polynomial-root} returns the result of -@var{prec} +iterations. +@end defun + + +@node Procedures, Standards Support, Numerics, Top +@chapter Procedures + +Anything that doesn't fall neatly into any of the other categories winds +up here. + +@menu +* Batch:: 'batch +* Common List Functions:: 'common-list-functions +* Format:: 'format +* Generic-Write:: 'generic-write +* Line I/O:: 'line-i/o +* Multi-Processing:: 'process +* Object-To-String:: 'object->string +* Pretty-Print:: 'pretty-print, 'pprint-file +* Sorting:: 'sort +* Topological Sort:: +* Standard Formatted I/O:: 'printf, 'scanf +* String-Case:: 'string-case +* String Ports:: 'string-port +* String Search:: +* Tektronix Graphics Support:: +* Tree Operations:: 'tree +@end menu + +@node Batch, Common List Functions, Procedures, Procedures +@section Batch + +@code{(require 'batch)} + +@noindent +The batch procedures provide a way to write and execute portable scripts +for a variety of operating systems. Each @code{batch:} procedure takes +as its first argument a parameter-list (@pxref{Parameter lists}). This +parameter-list argument @var{parms} contains named associations. Batch +currently uses 2 of these: + +@table @code +@item batch-port +The port on which to write lines of the batch file. +@item batch-dialect +The syntax of batch file to generate. Currently supported are: +@itemize @bullet +@item +unix +@item +dos +@item +vms +@item +system +@item +*unknown* +@end itemize +@end table + +@noindent +@file{batch.scm} uses 2 enhanced relational tables (@pxref{Database +Utilities}) to store information linking the names of +@code{operating-system}s to @code{batch-dialect}es. + +@defun batch:initialize! database +Defines @code{operating-system} and @code{batch-dialect} tables and adds +the domain @code{operating-system} to the enhanced relational database +@var{database}. +@end defun + +@defvar batch:platform +Is batch's best guess as to which operating-system it is running under. +@code{batch:platform} is set to @code{(software-type)} +(@pxref{Configuration}) unless @code{(software-type)} is @code{unix}, +in which case finer distinctions are made. +@end defvar + +@defun batch:call-with-output-script parms file proc +@var{proc} should be a procedure of one argument. If @var{file} is an +output-port, @code{batch:call-with-output-script} writes an appropriate +header to @var{file} and then calls @var{proc} with @var{file} as the +only argument. If @var{file} is a string, +@code{batch:call-with-output-script} opens a output-file of name +@var{file}, writes an appropriate header to @var{file}, and then calls +@var{proc} with the newly opened port as the only argument. Otherwise, +@code{batch:call-with-output-script} acts as if it was called with the +result of @code{(current-output-port)} as its third argument. +@end defun + +@defun batch:apply-chop-to-fit proc arg1 arg2 @dots{} list +The procedure @var{proc} must accept at least one argument and return +@code{#t} if successful, @code{#f} if not. +@code{batch:apply-chop-to-fit} calls @var{proc} with @var{arg1}, +@var{arg2}, @dots{}, and @var{chunk}, where @var{chunk} is a subset of +@var{list}. @code{batch:apply-chop-to-fit} tries @var{proc} with +successively smaller subsets of @var{list} until either @var{proc} +returns non-false, or the @var{chunk}s become empty. +@end defun + +@noindent +The rest of the @code{batch:} procedures write (or execute if +@code{batch-dialect} is @code{system}) commands to the batch port which +has been added to @var{parms} or @code{(copy-tree @var{parms})} by the +code: + +@example +(adjoin-parameters! @var{parms} (list 'batch-port @var{port})) +@end example + +@defun batch:system parms string1 string2 @dots{} +Calls @code{batch:try-system} (below) with arguments, but signals an +error if @code{batch:try-system} returns @code{#f}. +@end defun + +@noindent +These functions return a non-false value if the command was successfully +translated into the batch dialect and @code{#f} if not. In the case of +the @code{system} dialect, the value is non-false if the operation +suceeded. + +@defun batch:try-system parms string1 string2 @dots{} +Writes a command to the @code{batch-port} in @var{parms} which executes +the program named @var{string1} with arguments @var{string2} @dots{}. +@end defun + +@defun batch:run-script parms string1 string2 @dots{} +Writes a command to the @code{batch-port} in @var{parms} which executes +the batch script named @var{string1} with arguments @var{string2} +@dots{}. + +@emph{Note:} @code{batch:run-script} and @code{batch:try-system} are not the +same for some operating systems (VMS). +@end defun + +@defun batch:comment parms line1 @dots{} +Writes comment lines @var{line1} @dots{} to the @code{batch-port} in +@var{parms}. +@end defun + +@defun batch:lines->file parms file line1 @dots{} +Writes commands to the @code{batch-port} in @var{parms} which create a +file named @var{file} with contents @var{line1} @dots{}. +@end defun + +@defun batch:delete-file parms file +Writes a command to the @code{batch-port} in @var{parms} which deletes +the file named @var{file}. +@end defun + +@defun batch:rename-file parms old-name new-name +Writes a command to the @code{batch-port} in @var{parms} which renames +the file @var{old-name} to @var{new-name}. +@end defun + +@noindent +In addition, batch provides some small utilities very useful for writing +scripts: + +@defun replace-suffix str old new +Returns a new string similar to @code{str} but with the suffix string +@var{old} removed and the suffix string @var{new} appended. If the end +of @var{str} does not match @var{old}, an error is signaled. +@end defun + +@defun string-join joiner string1 @dots{} +Returns a new string consisting of all the strings @var{string1} @dots{} +in order appended together with the string @var{joiner} between each +adjacent pair. +@end defun + +@defun must-be-first list1 list2 +Returns a new list consisting of the elements of @var{list2} ordered so +that if some elements of @var{list1} are @code{equal?} to elements of +@var{list2}, then those elements will appear first and in the order of +@var{list1}. +@end defun + +@defun must-be-last list1 list2 +Returns a new list consisting of the elements of @var{list1} ordered so +that if some elements of @var{list2} are @code{equal?} to elements of +@var{list1}, then those elements will appear last and in the order of +@var{list2}. +@end defun + +@defun os->batch-dialect osname +Returns its best guess for the @code{batch-dialect} to be used for the +operating-system named @var{osname}. @code{os->batch-dialect} uses the +tables added to @var{database} by @code{batch:initialize!}. +@end defun + +@noindent +Here is an example of the use of most of batch's procedures: + +@example +(require 'database-utilities) +(require 'parameters) +(require 'batch) + +(define batch (create-database #f 'alist-table)) +(batch:initialize! batch) + +(define my-parameters + (list (list 'batch-dialect (os->batch-dialect batch:platform)) + (list 'platform batch:platform) + (list 'batch-port (current-output-port)))) ;gets filled in later + +(batch:call-with-output-script + my-parameters + "my-batch" + (lambda (batch-port) + (adjoin-parameters! my-parameters (list 'batch-port batch-port)) + (and + (batch:comment my-parameters + "================ Write file with C program.") + (batch:rename-file my-parameters "hello.c" "hello.c~") + (batch:lines->file my-parameters "hello.c" + "#include " + "int main(int argc, char **argv)" + "@{" + " printf(\"hello world\\n\");" + " return 0;" + "@}" ) + (batch:system my-parameters "cc" "-c" "hello.c") + (batch:system my-parameters "cc" "-o" "hello" + (replace-suffix "hello.c" ".c" ".o")) + (batch:system my-parameters "hello") + (batch:delete-file my-parameters "hello") + (batch:delete-file my-parameters "hello.c") + (batch:delete-file my-parameters "hello.o") + (batch:delete-file my-parameters "my-batch") + ))) +@end example + +@noindent +Produces the file @file{my-batch}: + +@example +#!/bin/sh +# "my-batch" build script created Sat Jun 10 21:20:37 1995 +# ================ Write file with C program. +mv -f hello.c hello.c~ +rm -f hello.c +echo '#include '>>hello.c +echo 'int main(int argc, char **argv)'>>hello.c +echo '@{'>>hello.c +echo ' printf("hello world\n");'>>hello.c +echo ' return 0;'>>hello.c +echo '@}'>>hello.c +cc -c hello.c +cc -o hello hello.o +hello +rm -f hello +rm -f hello.c +rm -f hello.o +rm -f my-batch +@end example + +@noindent +When run, @file{my-batch} prints: + +@example +bash$ my-batch +mv: hello.c: No such file or directory +hello world +@end example + + +@node Common List Functions, Format, Batch, Procedures +@section Common List Functions + +@code{(require 'common-list-functions)} + +The procedures below follow the Common LISP equivalents apart from +optional arguments in some cases. + +@menu +* List construction:: +* Lists as sets:: +* Lists as sequences:: +* Destructive list operations:: +* Non-List functions:: +@end menu + + +@node List construction, Lists as sets, Common List Functions, Common List Functions +@subsection List construction + +@defun make-list k . init +@code{make-list} creates and returns a list of @var{k} elements. If +@var{init} is included, all elements in the list are initialized to +@var{init}.@refill + +Example: +@lisp +(make-list 3) + @result{} (# # #) +(make-list 5 'foo) + @result{} (foo foo foo foo foo) +@end lisp +@end defun + + +@defun list* x . y +Works like @code{list} except that the cdr of the last pair is the last +argument unless there is only one argument, when the result is just that +argument. Sometimes called @code{cons*}. E.g.:@refill +@lisp +(list* 1) + @result{} 1 +(list* 1 2 3) + @result{} (1 2 . 3) +(list* 1 2 '(3 4)) + @result{} (1 2 3 4) +(list* @var{args} '()) + @equiv{} (list @var{args}) +@end lisp +@end defun + +@defun copy-list lst +@code{copy-list} makes a copy of @var{lst} using new pairs and returns +it. Only the top level of the list is copied, i.e., pairs forming +elements of the copied list remain @code{eq?} to the corresponding +elements of the original; the copy is, however, not @code{eq?} to the +original, but is @code{equal?} to it.@refill + +Example: +@lisp +(copy-list '(foo foo foo)) + @result{} (foo foo foo) +(define q '(foo bar baz bang)) +(define p q) +(eq? p q) + @result{} #t +(define r (copy-list q)) +(eq? q r) + @result{} #f +(equal? q r) + @result{} #t +(define bar '(bar)) +(eq? bar (car (copy-list (list bar 'foo)))) +@result{} #t + @end lisp +@end defun + + + + + + +@node Lists as sets, Lists as sequences, List construction, Common List Functions +@subsection Lists as sets + +@code{eq?} is used to test for membership by all the procedures below +which treat lists as sets.@refill + +@defun adjoin e l +@code{adjoin} returns the adjoint of the element @var{e} and the list +@var{l}. That is, if @var{e} is in @var{l}, @code{adjoin} returns +@var{l}, otherwise, it returns @code{(cons @var{e} @var{l})}.@refill + +Example: +@lisp +(adjoin 'baz '(bar baz bang)) + @result{} (bar baz bang) +(adjoin 'foo '(bar baz bang)) + @result{} (foo bar baz bang) +@end lisp +@end defun + +@defun union l1 l2 +@code{union} returns the combination of @var{l1} and @var{l2}. +Duplicates between @var{l1} and @var{l2} are culled. Duplicates within +@var{l1} or within @var{l2} may or may not be removed.@refill + +Example: +@lisp +(union '(1 2 3 4) '(5 6 7 8)) + @result{} (4 3 2 1 5 6 7 8) +(union '(1 2 3 4) '(3 4 5 6)) + @result{} (2 1 3 4 5 6) +@end lisp +@end defun + +@defun intersection l1 l2 +@code{intersection} returns all elements that are in both @var{l1} and +@var{l2}.@refill + +Example: +@lisp +(intersection '(1 2 3 4) '(3 4 5 6)) + @result{} (3 4) +(intersection '(1 2 3 4) '(5 6 7 8)) + @result{} () +@end lisp +@end defun + +@defun set-difference l1 l2 +@code{set-difference} returns the union of all elements that are in +@var{l1} but not in @var{l2}.@refill + +Example: +@lisp +(set-difference '(1 2 3 4) '(3 4 5 6)) + @result{} (1 2) +(set-difference '(1 2 3 4) '(1 2 3 4 5 6)) + @result{} () +@end lisp +@end defun + +@defun member-if pred lst +@code{member-if} returns @var{lst} if @code{(@var{pred} @var{element})} +is @code{#t} for any @var{element} in @var{lst}. Returns @code{#f} if +@var{pred} does not apply to any @var{element} in @var{lst}.@refill + +Example: +@lisp +(member-if vector? '(1 2 3 4)) + @result{} #f +(member-if number? '(1 2 3 4)) + @result{} (1 2 3 4) +@end lisp +@end defun + +@defun some pred lst . more-lsts +@var{pred} is a boolean function of as many arguments as there are list +arguments to @code{some} i.e., @var{lst} plus any optional arguments. +@var{pred} is applied to successive elements of the list arguments in +order. @code{some} returns @code{#t} as soon as one of these +applications returns @code{#t}, and is @code{#f} if none returns +@code{#t}. All the lists should have the same length.@refill + + +Example: +@lisp +(some odd? '(1 2 3 4)) + @result{} #t + +(some odd? '(2 4 6 8)) + @result{} #f + +(some > '(2 3) '(1 4)) + @result{} #f +@end lisp +@end defun + +@defun every pred lst . more-lsts +@code{every} is analogous to @code{some} except it returns @code{#t} if +every application of @var{pred} is @code{#t} and @code{#f} +otherwise.@refill + +Example: +@lisp +(every even? '(1 2 3 4)) + @result{} #f + +(every even? '(2 4 6 8)) + @result{} #t + +(every > '(2 3) '(1 4)) + @result{} #f +@end lisp +@end defun + +@defun notany pred . lst +@code{notany} is analogous to @code{some} but returns @code{#t} if no +application of @var{pred} returns @code{#t} or @code{#f} as soon as any +one does.@refill +@end defun + +@defun notevery pred . lst +@code{notevery} is analogous to @code{some} but returns @code{#t} as soon +as an application of @var{pred} returns @code{#f}, and @code{#f} +otherwise.@refill + +Example: +@lisp +(notevery even? '(1 2 3 4)) + @result{} #t + +(notevery even? '(2 4 6 8)) + @result{} #f +@end lisp +@end defun + +@defun find-if pred lst +@code{find-if} searches for the first @var{element} in @var{lst} such +that @code{(@var{pred} @var{element})} returns @code{#t}. If it finds +any such @var{element} in @var{lst}, @var{element} is returned. +Otherwise, @code{#f} is returned.@refill + +Example: +@lisp +(find-if number? '(foo 1 bar 2)) + @result{} 1 + +(find-if number? '(foo bar baz bang)) + @result{} #f + +(find-if symbol? '(1 2 foo bar)) + @result{} foo +@end lisp +@end defun + +@defun remove elt lst +@code{remove} removes all occurrences of @var{elt} from @var{lst} using +@code{eqv?} to test for equality and returns everything that's left. +N.B.: other implementations (Chez, Scheme->C and T, at least) use +@code{equal?} as the equality test.@refill + +Example: +@lisp +(remove 1 '(1 2 1 3 1 4 1 5)) + @result{} (2 3 4 5) + +(remove 'foo '(bar baz bang)) + @result{} (bar baz bang) +@end lisp +@end defun + +@defun remove-if pred lst +@code{remove-if} removes all @var{element}s from @var{lst} where +@code{(@var{pred} @var{element})} is @code{#t} and returns everything +that's left.@refill + +Example: +@lisp +(remove-if number? '(1 2 3 4)) + @result{} () + +(remove-if even? '(1 2 3 4 5 6 7 8)) + @result{} (1 3 5 7) +@end lisp +@end defun + +@defun remove-if-not pred lst +@code{remove-if-not} removes all @var{element}s from @var{lst} for which +@code{(@var{pred} @var{element})} is @code{#f} and returns everything that's +left.@refill + +Example: +@lisp +(remove-if-not number? '(foo bar baz)) + @result{} () +(remove-if-not odd? '(1 2 3 4 5 6 7 8)) + @result{} (1 3 5 7) +@end lisp +@end defun + +@defun has-duplicates? lst +returns @code{#t} if 2 members of @var{lst} are @code{equal?}, @code{#f} +otherwise. +Example: +@lisp +(has-duplicates? '(1 2 3 4)) + @result{} #f + +(has-duplicates? '(2 4 3 4)) + @result{} #t +@end lisp +@end defun + + +@node Lists as sequences, Destructive list operations, Lists as sets, Common List Functions +@subsection Lists as sequences + +@defun position obj lst +@code{position} returns the 0-based position of @var{obj} in @var{lst}, +or @code{#f} if @var{obj} does not occur in @var{lst}.@refill + +Example: +@lisp +(position 'foo '(foo bar baz bang)) + @result{} 0 +(position 'baz '(foo bar baz bang)) + @result{} 2 +(position 'oops '(foo bar baz bang)) + @result{} #f +@end lisp +@end defun + +@defun reduce p lst +@code{reduce} combines all the elements of a sequence using a binary +operation (the combination is left-associative). For example, using +@code{+}, one can add up all the elements. @code{reduce} allows you to +apply a function which accepts only two arguments to more than 2 +objects. Functional programmers usually refer to this as @dfn{foldl}. +@code{collect:reduce} (@xref{Collections}) provides a version of +@code{collect} generalized to collections.@refill + +Example: +@lisp +(reduce + '(1 2 3 4)) + @result{} 10 +(define (bad-sum . l) (reduce + l)) +(bad-sum 1 2 3 4) + @equiv{} (reduce + (1 2 3 4)) + @equiv{} (+ (+ (+ 1 2) 3) 4) +@result{} 10 +(bad-sum) + @equiv{} (reduce + ()) + @result{} () +(reduce string-append '("hello" "cruel" "world")) + @equiv{} (string-append (string-append "hello" "cruel") "world") + @result{} "hellocruelworld" +(reduce anything '()) + @result{} () +(reduce anything '(x)) + @result{} x +@end lisp + +What follows is a rather non-standard implementation of @code{reverse} +in terms of @code{reduce} and a combinator elsewhere called +@dfn{C}.@refill + +@lisp +;;; Contributed by Jussi Piitulainen (jpiitula@@ling.helsinki.fi) + +(define commute + (lambda (f) + (lambda (x y) + (f y x)))) + +(define reverse + (lambda (args) + (reduce-init (commute cons) args))) +@end lisp +@end defun + +@defun reduce-init p init lst +@code{reduce-init} is the same as reduce, except that it implicitly +inserts @var{init} at the start of the list. @code{reduce-init} is +preferred if you want to handle the null list, the one-element, and +lists with two or more elements consistently. It is common to use the +operator's idempotent as the initializer. Functional programmers +usually call this @dfn{foldl}.@refill + +Example: +@lisp +(define (sum . l) (reduce-init + 0 l)) +(sum 1 2 3 4) + @equiv{} (reduce-init + 0 (1 2 3 4)) + @equiv{} (+ (+ (+ (+ 0 1) 2) 3) 4) + @result{} 10 +(sum) + @equiv{} (reduce-init + 0 '()) + @result{} 0 + +(reduce-init string-append "@@" '("hello" "cruel" "world")) +@equiv{} +(string-append (string-append (string-append "@@" "hello") + "cruel") + "world") +@result{} "@@hellocruelworld" +@end lisp + +Given a differentiation of 2 arguments, @code{diff}, the following will +differentiate by any number of variables. +@lisp +(define (diff* exp . vars) + (reduce-init diff exp vars)) +@end lisp + +Example: +@lisp +;;; Real-world example: Insertion sort using reduce-init. + +(define (insert l item) + (if (null? l) + (list item) + (if (< (car l) item) + (cons (car l) (insert (cdr l) item)) + (cons item l)))) +(define (insertion-sort l) (reduce-init insert '() l)) + +(insertion-sort '(3 1 4 1 5) + @equiv{} (reduce-init insert () (3 1 4 1 5)) + @equiv{} (insert (insert (insert (insert (insert () 3) 1) 4) 1) 5) + @equiv{} (insert (insert (insert (insert (3)) 1) 4) 1) 5) + @equiv{} (insert (insert (insert (1 3) 4) 1) 5) + @equiv{} (insert (insert (1 3 4) 1) 5) + @equiv{} (insert (1 1 3 4) 5) + @result{} (1 1 3 4 5) + @end lisp +@end defun + +@defun butlast lst n +@code{butlast} returns all but the last @var{n} elements of +@var{lst}.@refill + +Example: +@lisp +(butlast '(1 2 3 4) 3) + @result{} (1) +(butlast '(1 2 3 4) 4) + @result{} () +@end lisp +@end defun + +@defun nthcdr n lst +@code{nthcdr} takes @var{n} @code{cdr}s of @var{lst} and returns the +result. Thus @code{(nthcdr 3 @var{lst})} @equiv{} @code{(cdddr +@var{lst})} + +Example: +@lisp +(nthcdr 2 '(1 2 3 4)) + @result{} (3 4) +(nthcdr 0 '(1 2 3 4)) + @result{} (1 2 3 4) +@end lisp +@end defun + +@defun last lst n +@code{last} returns the last @var{n} elements of @var{lst}. @var{n} +must be a non-negative integer. + +Example: +@lisp +(last '(foo bar baz bang) 2) + @result{} (baz bang) +(last '(1 2 3) 0) + @result{} 0 +@end lisp +@end defun + + + + + + +@node Destructive list operations, Non-List functions, Lists as sequences, Common List Functions +@subsection Destructive list operations + +These procedures may mutate the list they operate on, but any such +mutation is undefined. + +@deffn Procedure nconc args +@code{nconc} destructively concatenates its arguments. (Compare this +with @code{append}, which copies arguments rather than destroying them.) +Sometimes called @code{append!} (@xref{Rev2 Procedures}).@refill + +Example: You want to find the subsets of a set. Here's the obvious way: + +@lisp +(define (subsets set) + (if (null? set) + '(()) + (append (mapcar (lambda (sub) (cons (car set) sub)) + (subsets (cdr set))) + (subsets (cdr set))))) +@end lisp +But that does way more consing than you need. Instead, you could +replace the @code{append} with @code{nconc}, since you don't have any +need for all the intermediate results.@refill + +Example: +@lisp +(define x '(a b c)) +(define y '(d e f)) +(nconc x y) + @result{} (a b c d e f) +x + @result{} (a b c d e f) +@end lisp + +@code{nconc} is the same as @code{append!} in @file{sc2.scm}. +@end deffn + +@deffn Procedure nreverse lst +@code{nreverse} reverses the order of elements in @var{lst} by mutating +@code{cdr}s of the list. Sometimes called @code{reverse!}.@refill + +Example: +@lisp +(define foo '(a b c)) +(nreverse foo) + @result{} (c b a) +foo + @result{} (a) +@end lisp + +Some people have been confused about how to use @code{nreverse}, +thinking that it doesn't return a value. It needs to be pointed out +that@refill +@lisp +(set! lst (nreverse lst)) +@end lisp +@noindent +is the proper usage, not +@lisp +(nreverse lst) +@end lisp +The example should suffice to show why this is the case. +@end deffn + +@deffn Procedure delete elt lst +@deffnx Procedure delete-if pred lst +@deffnx Procedure delete-if-not pred lst +Destructive versions of @code{remove} @code{remove-if}, and +@code{remove-if-not}.@refill + +Example: +@lisp +(define lst '(foo bar baz bang)) +(delete 'foo lst) + @result{} (bar baz bang) +lst + @result{} (foo bar baz bang) + +(define lst '(1 2 3 4 5 6 7 8 9)) +(delete-if odd? lst) + @result{} (2 4 6 8) +lst + @result{} (1 2 4 6 8) +@end lisp + +Some people have been confused about how to use @code{delete}, +@code{delete-if}, and @code{delete-if}, thinking that they dont' return +a value. It needs to be pointed out that@refill +@lisp +(set! lst (delete el lst)) +@end lisp +@noindent +is the proper usage, not +@lisp +(delete el lst) +@end lisp +The examples should suffice to show why this is the case. +@end deffn + + + +@node Non-List functions, , Destructive list operations, Common List Functions +@subsection Non-List functions + +@defun and? . args +@code{and?} checks to see if all its arguments are true. If they are, +@code{and?} returns @code{#t}, otherwise, @code{#f}. (In contrast to +@code{and}, this is a function, so all arguments are always evaluated +and in an unspecified order.)@refill + +Example: +@lisp +(and? 1 2 3) + @result{} #t +(and #f 1 2) + @result{} #f +@end lisp +@end defun + +@defun or? . args +@code{or?} checks to see if any of its arguments are true. If any is +true, @code{or?} returns @code{#t}, and @code{#f} otherwise. (To +@code{or} as @code{and?} is to @code{and}.)@refill + +Example: +@lisp +(or? 1 2 #f) + @result{} #t +(or? #f #f #f) + @result{} #f +@end lisp +@end defun + +@defun atom? object +Returns @code{#t} if @var{object} is not a pair and @code{#f} if it is +pair. (Called @code{atom} in Common LISP.) +@lisp +(atom? 1) + @result{} #t +(atom? '(1 2)) + @result{} #f +(atom? #(1 2)) ; dubious! + @result{} #t +@end lisp +@end defun + +@defun type-of object +Returns a symbol name for the type of @var{object}. +@end defun + +@defun coerce object result-type +Converts and returns @var{object} of type @code{char}, @code{number}, +@code{string}, @code{symbol}, @code{list}, or @code{vector} to +@var{result-type} (which must be one of these symbols). +@end defun + +@node Format, Generic-Write, Common List Functions, Procedures +@section Format + +@code{(require 'format)} + +@menu +* Format Interface:: +* Format Specification:: +@end menu + +@node Format Interface, Format Specification, Format, Format +@subsection Format Interface + +@defun format destination format-string . arguments +An almost complete implementation of Common LISP format description +according to the CL reference book @cite{Common LISP} from Guy L. +Steele, Digital Press. Backward compatible to most of the available +Scheme format implementations. + +Returns @code{#t}, @code{#f} or a string; has side effect of printing +according to @var{format-string}. If @var{destination} is @code{#t}, +the output is to the current output port and @code{#t} is returned. If +@var{destination} is @code{#f}, a formatted string is returned as the +result of the call. NEW: If @var{destination} is a string, +@var{destination} is regarded as the format string; @var{format-string} is +then the first argument and the output is returned as a string. If +@var{destination} is a number, the output is to the current error port +if available by the implementation. Otherwise @var{destination} must be +an output port and @code{#t} is returned.@refill + +@var{format-string} must be a string. In case of a formatting error +format returns @code{#f} and prints a message on the current output or +error port. Characters are output as if the string were output by the +@code{display} function with the exception of those prefixed by a tilde +(~). For a detailed description of the @var{format-string} syntax +please consult a Common LISP format reference manual. For a test suite +to verify this format implementation load @file{formatst.scm}. Please +send bug reports to @code{lutzeb@@cs.tu-berlin.de}. + +Note: @code{format} is not reentrant, i.e. only one @code{format}-call +may be executed at a time. + +@end defun + +@node Format Specification, , Format Interface, Format +@subsection Format Specification (Format version 3.0) + +Please consult a Common LISP format reference manual for a detailed +description of the format string syntax. For a demonstration of the +implemented directives see @file{formatst.scm}.@refill + +This implementation supports directive parameters and modifiers +(@code{:} and @code{@@} characters). Multiple parameters must be +separated by a comma (@code{,}). Parameters can be numerical parameters +(positive or negative), character parameters (prefixed by a quote +character (@code{'}), variable parameters (@code{v}), number of rest +arguments parameter (@code{#}), empty and default parameters. Directive +characters are case independent. The general form of a directive +is:@refill + +@noindent +@var{directive} ::= ~@{@var{directive-parameter},@}[:][@@]@var{directive-character} + +@noindent +@var{directive-parameter} ::= [ [-|+]@{0-9@}+ | '@var{character} | v | # ] + + +@subsubsection Implemented CL Format Control Directives + +Documentation syntax: Uppercase characters represent the corresponding +control directive characters. Lowercase characters represent control +directive parameter descriptions. + +@table @asis +@item @code{~A} +Any (print as @code{display} does). +@table @asis +@item @code{~@@A} +left pad. +@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}A} +full padding. +@end table +@item @code{~S} +S-expression (print as @code{write} does). +@table @asis +@item @code{~@@S} +left pad. +@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}S} +full padding. +@end table +@item @code{~D} +Decimal. +@table @asis +@item @code{~@@D} +print number sign always. +@item @code{~:D} +print comma separated. +@item @code{~@var{mincol},@var{padchar},@var{commachar}D} +padding. +@end table +@item @code{~X} +Hexadecimal. +@table @asis +@item @code{~@@X} +print number sign always. +@item @code{~:X} +print comma separated. +@item @code{~@var{mincol},@var{padchar},@var{commachar}X} +padding. +@end table +@item @code{~O} +Octal. +@table @asis +@item @code{~@@O} +print number sign always. +@item @code{~:O} +print comma separated. +@item @code{~@var{mincol},@var{padchar},@var{commachar}O} +padding. +@end table +@item @code{~B} +Binary. +@table @asis +@item @code{~@@B} +print number sign always. +@item @code{~:B} +print comma separated. +@item @code{~@var{mincol},@var{padchar},@var{commachar}B} +padding. +@end table +@item @code{~@var{n}R} +Radix @var{n}. +@table @asis +@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar}R} +padding. +@end table +@item @code{~@@R} +print a number as a Roman numeral. +@item @code{~:R} +print a number as an ordinal English number. +@item @code{~:@@R} +print a number as a cardinal English number. +@item @code{~P} +Plural. +@table @asis +@item @code{~@@P} +prints @code{y} and @code{ies}. +@item @code{~:P} +as @code{~P but jumps 1 argument backward.} +@item @code{~:@@P} +as @code{~@@P but jumps 1 argument backward.} +@end table +@item @code{~C} +Character. +@table @asis +@item @code{~@@C} +prints a character as the reader can understand it (i.e. @code{#\} prefixing). +@item @code{~:C} +prints a character as emacs does (eg. @code{^C} for ASCII 03). +@end table +@item @code{~F} +Fixed-format floating-point (prints a flonum like @var{mmm.nnn}). +@table @asis +@item @code{~@var{width},@var{digits},@var{scale},@var{overflowchar},@var{padchar}F} +@item @code{~@@F} +If the number is positive a plus sign is printed. +@end table +@item @code{~E} +Exponential floating-point (prints a flonum like @var{mmm.nnn@code{E}ee}). +@table @asis +@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}E} +@item @code{~@@E} +If the number is positive a plus sign is printed. +@end table +@item @code{~G} +General floating-point (prints a flonum either fixed or exponential). +@table @asis +@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}G} +@item @code{~@@G} +If the number is positive a plus sign is printed. +@end table +@item @code{~$} +Dollars floating-point (prints a flonum in fixed with signs separated). +@table @asis +@item @code{~@var{digits},@var{scale},@var{width},@var{padchar}$} +@item @code{~@@$} +If the number is positive a plus sign is printed. +@item @code{~:@@$} +A sign is always printed and appears before the padding. +@item @code{~:$} +The sign appears before the padding. +@end table +@item @code{~%} +Newline. +@table @asis +@item @code{~@var{n}%} +print @var{n} newlines. +@end table +@item @code{~&} +print newline if not at the beginning of the output line. +@table @asis +@item @code{~@var{n}&} +prints @code{~&} and then @var{n-1} newlines. +@end table +@item @code{~|} +Page Separator. +@table @asis +@item @code{~@var{n}|} +print @var{n} page separators. +@end table +@item @code{~~} +Tilde. +@table @asis +@item @code{~@var{n}~} +print @var{n} tildes. +@end table +@item @code{~} +Continuation Line. +@table @asis +@item @code{~:} +newline is ignored, white space left. +@item @code{~@@} +newline is left, white space ignored. +@end table +@item @code{~T} +Tabulation. +@table @asis +@item @code{~@@T} +relative tabulation. +@item @code{~@var{colnum,colinc}T} +full tabulation. +@end table +@item @code{~?} +Indirection (expects indirect arguments as a list). +@table @asis +@item @code{~@@?} +extracts indirect arguments from format arguments. +@end table +@item @code{~(@var{str}~)} +Case conversion (converts by @code{string-downcase}). +@table @asis +@item @code{~:(@var{str}~)} +converts by @code{string-capitalize}. +@item @code{~@@(@var{str}~)} +converts by @code{string-capitalize-first}. +@item @code{~:@@(@var{str}~)} +converts by @code{string-upcase}. +@end table +@item @code{~*} +Argument Jumping (jumps 1 argument forward). +@table @asis +@item @code{~@var{n}*} +jumps @var{n} arguments forward. +@item @code{~:*} +jumps 1 argument backward. +@item @code{~@var{n}:*} +jumps @var{n} arguments backward. +@item @code{~@@*} +jumps to the 0th argument. +@item @code{~@var{n}@@*} +jumps to the @var{n}th argument (beginning from 0) +@end table +@item @code{~[@var{str0}~;@var{str1}~;...~;@var{strn}~]} +Conditional Expression (numerical clause conditional). +@table @asis +@item @code{~@var{n}[} +take argument from @var{n}. +@item @code{~@@[} +true test conditional. +@item @code{~:[} +if-else-then conditional. +@item @code{~;} +clause separator. +@item @code{~:;} +default clause follows. +@end table +@item @code{~@{@var{str}~@}} +Iteration (args come from the next argument (a list)). +@table @asis +@item @code{~@var{n}@{} +at most @var{n} iterations. +@item @code{~:@{} +args from next arg (a list of lists). +@item @code{~@@@{} +args from the rest of arguments. +@item @code{~:@@@{} +args from the rest args (lists). +@end table +@item @code{~^} +Up and out. +@table @asis +@item @code{~@var{n}^} +aborts if @var{n} = 0 +@item @code{~@var{n},@var{m}^} +aborts if @var{n} = @var{m} +@item @code{~@var{n},@var{m},@var{k}^} +aborts if @var{n} <= @var{m} <= @var{k} +@end table +@end table + + +@subsubsection Not Implemented CL Format Control Directives + +@table @asis +@item @code{~:A} +print @code{#f} as an empty list (see below). +@item @code{~:S} +print @code{#f} as an empty list (see below). +@item @code{~<~>} +Justification. +@item @code{~:^} +(sorry I don't understand its semantics completely) +@end table + + +@subsubsection Extended, Replaced and Additional Control Directives + +@table @asis +@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}D} +@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}X} +@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}O} +@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}B} +@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar},@var{commawidth}R} +@var{commawidth} is the number of characters between two comma characters. +@end table + +@table @asis +@item @code{~I} +print a R4RS complex number as @code{~F~@@Fi} with passed parameters for +@code{~F}. +@item @code{~Y} +Pretty print formatting of an argument for scheme code lists. +@item @code{~K} +Same as @code{~?.} +@item @code{~!} +Flushes the output if format @var{destination} is a port. +@item @code{~_} +Print a @code{#\space} character +@table @asis +@item @code{~@var{n}_} +print @var{n} @code{#\space} characters. +@end table +@item @code{~/} +Print a @code{#\tab} character +@table @asis +@item @code{~@var{n}/} +print @var{n} @code{#\tab} characters. +@end table +@item @code{~@var{n}C} +Takes @var{n} as an integer representation for a character. No arguments +are consumed. @var{n} is converted to a character by +@code{integer->char}. @var{n} must be a positive decimal number.@refill +@item @code{~:S} +Print out readproof. Prints out internal objects represented as +@code{#<...>} as strings @code{"#<...>"} so that the format output can always +be processed by @code{read}. +@refill +@item @code{~:A} +Print out readproof. Prints out internal objects represented as +@code{#<...>} as strings @code{"#<...>"} so that the format output can always +be processed by @code{read}. +@item @code{~Q} +Prints information and a copyright notice on the format implementation. +@table @asis +@item @code{~:Q} +prints format version. +@end table +@refill +@item @code{~F, ~E, ~G, ~$} +may also print number strings, i.e. passing a number as a string and +format it accordingly. +@end table + +@subsubsection Configuration Variables + +Format has some configuration variables at the beginning of +@file{format.scm} to suit the systems and users needs. There should be +no modification necessary for the configuration that comes with SLIB. +If modification is desired the variable should be set after the format +code is loaded. Format detects automatically if the running scheme +system implements floating point numbers and complex numbers. + +@table @asis + +@item @var{format:symbol-case-conv} +Symbols are converted by @code{symbol->string} so the case type of the +printed symbols is implementation dependent. +@code{format:symbol-case-conv} is a one arg closure which is either +@code{#f} (no conversion), @code{string-upcase}, @code{string-downcase} +or @code{string-capitalize}. (default @code{#f}) + +@item @var{format:iobj-case-conv} +As @var{format:symbol-case-conv} but applies for the representation of +implementation internal objects. (default @code{#f}) + +@item @var{format:expch} +The character prefixing the exponent value in @code{~E} printing. (default +@code{#\E}) + +@end table + +@subsubsection Compatibility With Other Format Implementations + +@table @asis +@item SLIB format 2.x: +See @file{format.doc}. + +@item SLIB format 1.4: +Downward compatible except for padding support and @code{~A}, @code{~S}, +@code{~P}, @code{~X} uppercase printing. SLIB format 1.4 uses C-style +@code{printf} padding support which is completely replaced by the CL +@code{format} padding style. + +@item MIT C-Scheme 7.1: +Downward compatible except for @code{~}, which is not documented +(ignores all characters inside the format string up to a newline +character). (7.1 implements @code{~a}, @code{~s}, +~@var{newline}, @code{~~}, @code{~%}, numerical and variable +parameters and @code{:/@@} modifiers in the CL sense).@refill + +@item Elk 1.5/2.0: +Downward compatible except for @code{~A} and @code{~S} which print in +uppercase. (Elk implements @code{~a}, @code{~s}, @code{~~}, and +@code{~%} (no directive parameters or modifiers)).@refill + +@item Scheme->C 01nov91: +Downward compatible except for an optional destination parameter: S2C +accepts a format call without a destination which returns a formatted +string. This is equivalent to a #f destination in S2C. (S2C implements +@code{~a}, @code{~s}, @code{~c}, @code{~%}, and @code{~~} (no directive +parameters or modifiers)).@refill + +@end table + +This implementation of format is solely useful in the SLIB context +because it requires other components provided by SLIB.@refill + + +@node Generic-Write, Line I/O, Format, Procedures +@section Generic-Write + +@code{(require 'generic-write)} + +@code{generic-write} is a procedure that transforms a Scheme data value +(or Scheme program expression) into its textual representation and +prints it. The interface to the procedure is sufficiently general to +easily implement other useful formatting procedures such as pretty +printing, output to a string and truncated output.@refill + +@deffn Procedure generic-write obj display? width output +@table @var +@item obj +Scheme data value to transform. +@item display? +Boolean, controls whether characters and strings are quoted. +@item width +Extended boolean, selects format: +@table @asis +@item #f +single line format +@item integer > 0 +pretty-print (value = max nb of chars per line) +@end table +@item output +Procedure of 1 argument of string type, called repeatedly with +successive substrings of the textual representation. This procedure can +return @code{#f} to stop the transformation. +@end table + +The value returned by @code{generic-write} is undefined. + +Examples: +@lisp +(write obj) @equiv{} (generic-write obj #f #f @var{display-string}) +(display obj) @equiv{} (generic-write obj #t #f @var{display-string}) +@end lisp +@noindent +where +@lisp +@var{display-string} @equiv{} +(lambda (s) (for-each write-char (string->list s)) #t) +@end lisp +@end deffn + + + + + +@node Line I/O, Multi-Processing, Generic-Write, Procedures +@section Line I/O + +@code{(require 'line-i/o)} + +@defun read-line +@defunx read-line port +Returns a string of the characters up to, but not including a newline or +end of file, updating @var{port} to point to the character following the +newline. If no characters are available, an end of file object is +returned. @var{port} may be omitted, in which case it defaults to the +value returned by @code{current-input-port}.@refill +@end defun + +@defun read-line! string +@defunx read-line! string port +Fills @var{string} with characters up to, but not including a newline or +end of file, updating the port to point to the last character read or +following the newline if it was read. If no characters are available, +an end of file object is returned. If a newline or end of file was +found, the number of characters read is returned. Otherwise, @code{#f} +is returned. @var{port} may be omitted, in which case it defaults to +the value returned by @code{current-input-port}.@refill +@end defun + +@defun write-line string +@defunx write-line string port +Writes @var{string} followed by a newline to the given port and returns +an unspecified value. Port may be omited, in which case it defaults to +the value returned by @code{current-input-port}.@refill +@end defun + + + + +@node Multi-Processing, Object-To-String, Line I/O, Procedures +@section Multi-Processing + +@code{(require 'process)} + +@deffn Procedure add-process! proc +Adds proc, which must be a procedure (or continuation) capable of +accepting accepting one argument, to the @code{process:queue}. The +value returned is unspecified. The argument to @var{proc} should be +ignored. If @var{proc} returns, the process is killed.@refill +@end deffn + +@deffn Procedure process:schedule! +Saves the current process on @code{process:queue} and runs the next +process from @code{process:queue}. The value returned is +unspecified.@refill +@end deffn + + +@deffn Procedure kill-process! +Kills the current process and runs the next process from +@code{process:queue}. If there are no more processes on +@code{process:queue}, @code{(slib:exit)} is called (@xref{System}). +@end deffn + + + + + +@node Object-To-String, Pretty-Print, Multi-Processing, Procedures +@section Object-To-String + +@code{(require 'object->string)} + +@defun object->string obj +Returns the textual representation of @var{obj} as a string. +@end defun + + + + +@node Pretty-Print, Sorting, Object-To-String, Procedures +@section Pretty-Print + +@code{(require 'pretty-print)} + +@deffn Procedure pretty-print obj +@deffnx Procedure pretty-print obj port + +@code{pretty-print}s @var{obj} on @var{port}. If @var{port} is not +specified, @code{current-output-port} is used. + +Example: +@example +@group +(pretty-print '((1 2 3 4 5) (6 7 8 9 10) (11 12 13 14 15) + (16 17 18 19 20) (21 22 23 24 25))) + @print{} ((1 2 3 4 5) + @print{} (6 7 8 9 10) + @print{} (11 12 13 14 15) + @print{} (16 17 18 19 20) + @print{} (21 22 23 24 25)) +@end group +@end example +@end deffn + + +@code{(require 'pprint-file)} + +@deffn Procedure pprint-file infile +@deffnx Procedure pprint-file infile outfile +Pretty-prints all the code in @var{infile}. If @var{outfile} is +specified, the output goes to @var{outfile}, otherwise it goes to +@code{(current-output-port)}.@refill +@end deffn + +@defun pprint-filter-file infile proc outfile +@defunx pprint-filter-file infile proc +@var{infile} is a port or a string naming an existing file. Scheme +source code expressions and definitions are read from the port (or file) +and @var{proc} is applied to them sequentially. + +@var{outfile} is a port or a string. If no @var{outfile} is specified +then @code{current-output-port} is assumed. These expanded expressions +are then @code{pretty-print}ed to this port. + +Whitepsace and comments (introduced by @code{;}) which are not part of +scheme expressions are reproduced in the output. This procedure does +not affect the values returned by @code{current-input-port} and +@code{current-output-port}.@refill +@end defun + +@code{pprint-filter-file} can be used to pre-compile macro-expansion and +thus can reduce loading time. The following will write into +@file{exp-code.scm} the result of expanding all defmacros in +@file{code.scm}. +@lisp +(require 'pprint-file) +(require 'defmacroexpand) +(defmacro:load "my-macros.scm") +(pprint-filter-file "code.scm" defmacro:expand* "exp-code.scm") +@end lisp + + +@node Sorting, Topological Sort, Pretty-Print, Procedures +@section Sorting + +@code{(require 'sort)} + +Many Scheme systems provide some kind of sorting functions. They do +not, however, always provide the @emph{same} sorting functions, and +those that I have had the opportunity to test provided inefficient ones +(a common blunder is to use quicksort which does not perform well). + +Because @code{sort} and @code{sort!} are not in the standard, there is +very little agreement about what these functions look like. For +example, Dybvig says that Chez Scheme provides +@lisp +(merge predicate list1 list2) +(merge! predicate list1 list2) +(sort predicate list) +(sort! predicate list) +@end lisp +@noindent +while MIT Scheme 7.1, following Common LISP, offers unstable +@lisp +(sort list predicate) +@end lisp +@noindent +TI PC Scheme offers +@lisp +(sort! list/vector predicate?) +@end lisp +@noindent +and Elk offers +@lisp +(sort list/vector predicate?) +(sort! list/vector predicate?) +@end lisp + +Here is a comprehensive catalogue of the variations I have found. + +@enumerate +@item +Both @code{sort} and @code{sort!} may be provided. +@item +@code{sort} may be provided without @code{sort!}. +@item +@code{sort!} may be provided without @code{sort}. +@item +Neither may be provided. +@item +The sequence argument may be either a list or a vector. +@item +The sequence argument may only be a list. +@item +The sequence argument may only be a vector. +@item +The comparison function may be expected to behave like @code{<}. +@item +The comparison function may be expected to behave like @code{<=}. +@item +The interface may be @code{(sort predicate? sequence)}. +@item +The interface may be @code{(sort sequence predicate?)}. +@item +The interface may be @code{(sort sequence &optional (predicate? <))}. +@item +The sort may be stable. +@item +The sort may be unstable. +@end enumerate + +All of this variation really does not help anybody. A nice simple merge +sort is both stable and fast (quite a lot faster than @emph{quick} sort). + +I am providing this source code with no restrictions at all on its use +(but please retain D.H.D.Warren's credit for the original idea). You +may have to rename some of these functions in order to use them in a +system which already provides incompatible or inferior sorts. For each +of the functions, only the top-level define needs to be edited to do +that. + +I could have given these functions names which would not clash with any +Scheme that I know of, but I would like to encourage implementors to +converge on a single interface, and this may serve as a hint. The +argument order for all functions has been chosen to be as close to +Common LISP as made sense, in order to avoid NIH-itis. + +Each of the five functions has a required @emph{last} parameter which is +a comparison function. A comparison function @code{f} is a function of +2 arguments which acts like @code{<}. For example,@refill + +@lisp +(not (f x x)) +(and (f x y) (f y z)) @equiv{} (f x z) +@end lisp + +The standard functions @code{<}, @code{>}, @code{char?}, +@code{char-ci?}, @code{string?}, +@code{string-ci?} are suitable for use as +comparison functions. Think of @code{(less? x y)} as saying when +@code{x} must @emph{not} precede @code{y}.@refill + +@defun sorted? sequence less? +Returns @code{#t} when the sequence argument is in non-decreasing order +according to @var{less?} (that is, there is no adjacent pair @code{@dots{} x +y @dots{}} for which @code{(less? y x)}).@refill + +Returns @code{#f} when the sequence contains at least one out-of-order +pair. It is an error if the sequence is neither a list nor a vector. +@end defun + +@defun merge list1 list2 less? +This merges two lists, producing a completely new list as result. I +gave serious consideration to producing a Common-LISP-compatible +version. However, Common LISP's @code{sort} is our @code{sort!} (well, +in fact Common LISP's @code{stable-sort} is our @code{sort!}, merge sort +is @emph{fast} as well as stable!) so adapting CL code to Scheme takes a +bit of work anyway. I did, however, appeal to CL to determine the +@emph{order} of the arguments. +@end defun + +@deffn Procedure merge! list1 list2 less? +Merges two lists, re-using the pairs of @var{list1} and @var{list2} to +build the result. If the code is compiled, and @var{less?} constructs +no new pairs, no pairs at all will be allocated. The first pair of the +result will be either the first pair of @var{list1} or the first pair of +@var{list2}, but you can't predict which. + +The code of @code{merge} and @code{merge!} could have been quite a bit +simpler, but they have been coded to reduce the amount of work done per +iteration. (For example, we only have one @code{null?} test per +iteration.)@refill +@end deffn + +@defun sort sequence less? +Accepts either a list or a vector, and returns a new sequence which is +sorted. The new sequence is the same type as the input. Always +@code{(sorted? (sort sequence less?) less?)}. The original sequence is +not altered in any way. The new sequence shares its @emph{elements} +with the old one; no elements are copied.@refill +@end defun + +@deffn Procedure sort! sequence less? +Returns its sorted result in the original boxes. If the original +sequence is a list, no new storage is allocated at all. If the original +sequence is a vector, the sorted elements are put back in the same +vector. + +Some people have been confused about how to use @code{sort!}, thinking +that it doesn't return a value. It needs to be pointed out that +@lisp +(set! slist (sort! slist <)) +@end lisp +@noindent +is the proper usage, not +@lisp +(sort! slist <) +@end lisp +@end deffn + +Note that these functions do @emph{not} accept a CL-style @samp{:key} +argument. A simple device for obtaining the same expressiveness is to +define@refill +@lisp +(define (keyed less? key) + (lambda (x y) (less? (key x) (key y)))) +@end lisp +@noindent +and then, when you would have written +@lisp +(sort a-sequence #'my-less :key #'my-key) +@end lisp +@noindent +in Common LISP, just write +@lisp +(sort! a-sequence (keyed my-less? my-key)) +@end lisp +@noindent +in Scheme. + +@node Topological Sort, Standard Formatted I/O, Sorting, Procedures +@section Topological Sort + +@code{(require 'topological-sort)} or @code{(require 'tsort)} + +@noindent +The algorithm is inspired by Cormen, Leiserson and Rivest (1990) +@cite{Introduction to Algorithms}, chapter 23. + +@defun tsort dag pred +@defunx topological-sort dag pred +where +@table @var +@item dag +is a list of sublists. The car of each sublist is a vertex. The cdr is +the adjacency list of that vertex, i.e. a list of all vertices to which +there exists an edge from the car vertex. +@item pred +is one of @code{eq?}, @code{eqv?}, @code{equal?}, @code{=}, +@code{char=?}, @code{char-ci=?}, @code{string=?}, or @code{string-ci=?}. +@end table + +Sort the directed acyclic graph @var{dag} so that for every edge from +vertex @var{u} to @var{v}, @var{u} will come before @var{v} in the +resulting list of vertices. + +Time complexity: O (|V| + |E|) + +Example (from Cormen): +@quotation +Prof. Bumstead topologically sorts his clothing when getting +dressed. The first argument to `tsort' describes which +garments he needs to put on before others. (For example, +Prof Bumstead needs to put on his shirt before he puts on his +tie or his belt.) `tsort' gives the correct order of dressing: +@end quotation + +@example +(require 'tsort) +(tsort '((shirt tie belt) + (tie jacket) + (belt jacket) + (watch) + (pants shoes belt) + (undershorts pants shoes) + (socks shoes)) + eq?) +@result{} +(socks undershorts pants shoes watch shirt belt tie jacket) +@end example +@end defun + +@node Standard Formatted I/O, String-Case, Topological Sort, Procedures +@section Standard Formatted I/O + +@menu +* Standard Formatted Output:: +* Standard Formatted Input:: +@end menu + +@subsection stdio + +@code{(require 'stdio)} + +@code{require}s @code{printf} and @code{scanf} and additionally defines +the symbols: + +@defvar stdin +Defined to be @code{(current-input-port)}. +@end defvar +@defvar stdout +Defined to be @code{(current-output-port)}. +@end defvar +@defvar stderr +Defined to be @code{(current-error-port)}. +@end defvar + + +@node Standard Formatted Output, Standard Formatted Input, Standard Formatted I/O, Standard Formatted I/O +@subsection Standard Formatted Output + +@code{(require 'printf)} + +@deffn Procedure printf format arg1 @dots{} +@deffnx Procedure fprintf port format arg1 @dots{} +@deffnx Procedure sprintf str format arg1 @dots{} + +Each function converts, formats, and outputs its @var{arg1} @dots{} +arguments according to the control string @var{format} argument and +returns the number of characters output. + +@code{printf} sends its output to the port @code{(current-output-port)}. +@code{fprintf} sends its output to the port @var{port}. @code{sprintf} +@code{string-set!}s locations of the non-constant string argument +@var{str} to the output characters. + +@quotation +@emph{Note:} sprintf should be changed to a macro so a @code{substring} +expression could be used for the @var{str} argument. +@end quotation + +The string @var{format} contains plain characters which are copied to +the output stream, and conversion specifications, each of which results +in fetching zero or more of the arguments @var{arg1} @dots{}. The +results are undefined if there are an insufficient number of arguments +for the format. If @var{format} is exhausted while some of the +@var{arg1} @dots{} arguments remain unused, the excess @var{arg1} +@dots{} arguments are ignored. + +The conversion specifications in a format string have the form: + +@example +% @r{[} @var{flags} @r{]} @r{[} @var{width} @r{]} @r{[} . @var{precision} @r{]} @r{[} @var{type} @r{]} @var{conversion} +@end example + +An output conversion specifications consist of an initial @samp{%} +character followed in sequence by: + +@itemize @bullet +@item +Zero or more @dfn{flag characters} that modify the normal behavior of +the conversion specification. + +@table @asis +@item @samp{-} +Left-justify the result in the field. Normally the result is +right-justified. + +@item @samp{+} +For the signed @samp{%d} and @samp{%i} conversions and all inexact +conversions, prefix a plus sign if the value is positive. + +@item @samp{ } +For the signed @samp{%d} and @samp{%i} conversions, if the result +doesn't start with a plus or minus sign, prefix it with a space +character instead. Since the @samp{+} flag ensures that the result +includes a sign, this flag is ignored if both are specified. + +@item @samp{#} +For inexact conversions, @samp{#} specifies that the result should +always include a decimal point, even if no digits follow it. For the +@samp{%g} and @samp{%G} conversions, this also forces trailing zeros +after the decimal point to be printed where they would otherwise be +elided. + +For the @samp{%o} conversion, force the leading digit to be @samp{0}, as +if by increasing the precision. For @samp{%x} or @samp{%X}, prefix a +leading @samp{0x} or @samp{0X} (respectively) to the result. This +doesn't do anything useful for the @samp{%d}, @samp{%i}, or @samp{%u} +conversions. Using this flag produces output which can be parsed by the +@code{scanf} functions with the @samp{%i} conversion (@pxref{Standard +Formatted Input}). + + +@item @samp{0} +Pad the field with zeros instead of spaces. The zeros are placed after +any indication of sign or base. This flag is ignored if the @samp{-} +flag is also specified, or if a precision is specified for an exact +converson. +@end table + +@item +An optional decimal integer specifying the @dfn{minimum field width}. +If the normal conversion produces fewer characters than this, the field +is padded (with spaces or zeros per the @samp{0} flag) to the specified +width. This is a @emph{minimum} width; if the normal conversion +produces more characters than this, the field is @emph{not} truncated. +@cindex minimum field width (@code{printf}) + +Alternatively, if the field width is @samp{*}, the next argument in the +argument list (before the actual value to be printed) is used as the +field width. The width value must be an integer. If the value is +negative it is as though the @samp{-} flag is set (see above) and the +absolute value is used as the field width. + +@item +An optional @dfn{precision} to specify the number of digits to be +written for numeric conversions and the maximum field width for string +conversions. The precision is specified by a period (@samp{.}) followed +optionally by a decimal integer (which defaults to zero if omitted). +@cindex precision (@code{printf}) + +Alternatively, if the precision is @samp{.*}, the next argument in the +argument list (before the actual value to be printed) is used as the +precision. The value must be an integer, and is ignored if negative. +If you specify @samp{*} for both the field width and precision, the +field width argument precedes the precision argument. The @samp{.*} +precision is an enhancement. C library versions may not accept this +syntax. + +For the @samp{%f}, @samp{%e}, and @samp{%E} conversions, the precision +specifies how many digits follow the decimal-point character. The +default precision is @code{6}. If the precision is explicitly @code{0}, +the decimal point character is suppressed. + +For the @samp{%g} and @samp{%G} conversions, the precision specifies how +many significant digits to print. Significant digits are the first +digit before the decimal point, and all the digits after it. If the +precision is @code{0} or not specified for @samp{%g} or @samp{%G}, it is +treated like a value of @code{1}. If the value being printed cannot be +expressed accurately in the specified number of digits, the value is +rounded to the nearest number that fits. + +For exact conversions, if a precision is supplied it specifies the +minimum number of digits to appear; leading zeros are produced if +necessary. If a precision is not supplied, the number is printed with +as many digits as necessary. Converting an exact @samp{0} with an +explicit precision of zero produces no characters. + +@item +An optional one of @samp{l}, @samp{h} or @samp{L}, which is ignored for +numeric conversions. It is an error to specify these modifiers for +non-numeric conversions. + +@item +A character that specifies the conversion to be applied. +@end itemize + +@subsubsection Exact Conversions + +@table @asis +@item @samp{d}, @samp{i} +Print an integer as a signed decimal number. @samp{%d} and @samp{%i} +are synonymous for output, but are different when used with @code{scanf} +for input (@pxref{Standard Formatted Input}). + +@item @samp{o} +Print an integer as an unsigned octal number. + +@item @samp{u} +Print an integer as an unsigned decimal number. + +@item @samp{x}, @samp{X} +Print an integer as an unsigned hexadecimal number. @samp{%x} prints +using the digits @samp{0123456789abcdef}. @samp{%X} prints using the +digits @samp{0123456789ABCDEF}. +@end table + +@subsubsection Inexact Conversions +@emph{Note:} Inexact conversions are not supported yet. + +@table @asis +@item @samp{f} +Print a floating-point number in fixed-point notation. + +@item @samp{e}, @samp{E} +Print a floating-point number in exponential notation. @samp{%e} prints +@samp{e} between mantissa and exponont. @samp{%E} prints @samp{E} +between mantissa and exponont. + +@item @samp{g}, @samp{G} +Print a floating-point number in either normal or exponential notation, +whichever is more appropriate for its magnitude. @samp{%g} prints +@samp{e} between mantissa and exponont. @samp{%G} prints @samp{E} +between mantissa and exponont. +@end table + +@subsubsection Other Conversions +@table @asis +@item @samp{c} +Print a single character. The @samp{-} flag is the only one which can +be specified. It is an error to specify a precision. + +@item @samp{s} +Print a string. The @samp{-} flag is the only one which can be +specified. A precision specifies the maximum number of characters to +output; otherwise all characters in the string are output. + +@item @samp{a}, @samp{A} +Print a scheme expression. The @samp{-} flag left-justifies the output. +The @samp{#} flag specifies that strings and characters should be quoted +as by @code{write} (which can be read using @code{read}); otherwise, +output is as @code{display} prints. A precision specifies the maximum +number of characters to output; otherwise as many characters as needed +are output. + +@emph{Note:} @samp{%a} and @samp{%A} are SLIB extensions. + +@c @item @samp{p} +@c Print the value of a pointer. + +@c @item @samp{n} +@c Get the number of characters printed so far. @xref{Other Output Conversions}. +@c Note that this conversion specification never produces any output. + +@c @item @samp{m} +@c Print the string corresponding to the value of @code{errno}. +@c (This is a GNU extension.) +@c @xref{Other Output Conversions}. + +@item @samp{%} +Print a literal @samp{%} character. No argument is consumed. It is an +error to specifiy flags, field width, precision, or type modifiers with +@samp{%%}. +@end table +@end deffn + + +@node Standard Formatted Input, , Standard Formatted Output, Standard Formatted I/O +@subsection Standard Formatted Input + +@code{(require 'scanf)} + +@deffn Function scanf-read-list format +@deffnx Function scanf-read-list format port +@deffnx Function scanf-read-list format string +@end deffn + +@defmac scanf format arg1 @dots{} +@defmacx fscanf port format arg1 @dots{} +@defmacx sscanf str format arg1 @dots{} + +Each function reads characters, interpreting them according to the +control string @var{format} argument. + +@code{scanf-read-list} returns a list of the items specified as far as +the input matches @var{format}. @code{scanf}, @code{fscanf}, and +@code{sscanf} return the number of items successfully matched and +stored. @code{scanf}, @code{fscanf}, and @code{sscanf} also set the +location corresponding to @var{arg1} @dots{} using the methods: + +@table @asis +@item symbol +@code{set!} +@item car expression +@code{set-car!} +@item cdr expression +@code{set-cdr!} +@item vector-ref expression +@code{vector-set!} +@item substring expression +@code{substring-move-left!} +@end table + +The argument to a @code{substring} expression in @var{arg1} @dots{} must +be a non-constant string. Characters will be stored starting at the +position specified by the second argument to @code{substring}. The +number of characters stored will be limited by either the position +specified by the third argument to @code{substring} or the length of the +matched string, whichever is less. + +The control string, @var{format}, contains conversion specifications and +other characters used to direct interpretation of input sequences. The +control string contains: + +@itemize @bullet +@item White-space characters (blanks, tabs, newlines, or formfeeds) +that cause input to be read (and discarded) up to the next +non-white-space character. + +@item An ordinary character (not @samp{%}) that must match the next +character of the input stream. + +@item Conversion specifications, consisting of the character @samp{%}, an +optional assignment suppressing character @samp{*}, an optional +numerical maximum-field width, an optional @samp{l}, @samp{h} or +@samp{L} which is ignored, and a conversion code. + +@c @item The conversion specification can alternatively be prefixed by +@c the character sequence @samp{%n$} instead of the character @samp{%}, +@c where @var{n} is a decimal integer in the range. The @samp{%n$} +@c construction indicates that the value of the next input field should be +@c placed in the @var{n}th place in the return list, rather than to the next +@c unused one. The two forms of introducing a conversion specification, +@c @samp{%} and @samp{%n$}, must not be mixed within a single format string +@c with the following exception: Skip fields (see below) can be designated +@c as @samp{%*} or @samp{%n$*}. In the latter case, @var{n} is ignored. + +@end itemize + +Unless the specification contains the @samp{n} conversion character +(described below), a conversion specification directs the conversion of +the next input field. The result of a conversion specification is +returned in the position of the corresponding argument points, unless +@samp{*} indicates assignment suppression. Assignment suppression +provides a way to describe an input field to be skipped. An input field +is defined as a string of characters; it extends to the next +inappropriate character or until the field width, if specified, is +exhausted. + +@quotation +@emph{Note:} This specification of format strings differs from the +@cite{ANSI C} and @cite{POSIX} specifications. In SLIB, white space +before an input field is not skipped unless white space appears before +the conversion specification in the format string. In order to write +format strings which work identically with @cite{ANSI C} and SLIB, +prepend whitespace to all conversion specifications except @samp{[} and +@samp{c}. +@end quotation + +The conversion code indicates the interpretation of the input field; For +a suppressed field, no value is returned. The following conversion +codes are legal: + +@table @asis + +@item @samp{%} +A single % is expected in the input at this point; no value is returned. + +@item @samp{d}, @samp{D} +A decimal integer is expected. + +@item @samp{u}, @samp{U} +An unsigned decimal integer is expected. + +@item @samp{o}, @samp{O} +An octal integer is expected. + +@item @samp{x}, @samp{X} +A hexadecimal integer is expected. + +@item @samp{i} +An integer is expected. Returns the value of the next input item, +interpreted according to C conventions; a leading @samp{0} implies +octal, a leading @samp{0x} implies hexadecimal; otherwise, decimal is +assumed. + +@item @samp{n} +Returns the total number of bytes (including white space) read by +@code{scanf}. No input is consumed by @code{%n}. + +@item @samp{f}, @samp{F}, @samp{e}, @samp{E}, @samp{g}, @samp{G} +A floating-point number is expected. The input format for +floating-point numbers is an optionally signed string of digits, +possibly containing a radix character @samp{.}, followed by an optional +exponent field consisting of an @samp{E} or an @samp{e}, followed by an +optional @samp{+}, @samp{-}, or space, followed by an integer. + +@item @samp{c}, @samp{C} +@var{Width} characters are expected. The normal skip-over-white-space +is suppressed in this case; to read the next non-space character, use +@samp{%1s}. If a field width is given, a string is returned; up to the +indicated number of characters is read. + +@item @samp{s}, @samp{S} +A character string is expected The input field is terminated by a +white-space character. @code{scanf} cannot read a null string. + +@item @samp{[} +Indicates string data and the normal skip-over-leading-white-space is +suppressed. The left bracket is followed by a set of characters, called +the scanset, and a right bracket; the input field is the maximal +sequence of input characters consisting entirely of characters in the +scanset. @samp{^}, when it appears as the first character in the +scanset, serves as a complement operator and redefines the scanset as +the set of all characters not contained in the remainder of the scanset +string. Construction of the scanset follows certain conventions. A +range of characters may be represented by the construct first-last, +enabling @samp{[0123456789]} to be expressed @samp{[0-9]}. Using this +convention, first must be lexically less than or equal to last; +otherwise, the dash stands for itself. The dash also stands for itself +when it is the first or the last character in the scanset. To include +the right square bracket as an element of the scanset, it must appear as +the first character (possibly preceded by a @samp{^}) of the scanset, in +which case it will not be interpreted syntactically as the closing +bracket. At least one character must match for this conversion to +succeed. +@end table + +The @code{scanf} functions terminate their conversions at end-of-file, +at the end of the control string, or when an input character conflicts +with the control string. In the latter case, the offending character is +left unread in the input stream. +@end defmac + +@node String-Case, String Ports, Standard Formatted I/O, Procedures +@section String-Case + +@code{(require 'string-case)} + +@deffn Procedure string-upcase str +@deffnx Procedure string-downcase str +@deffnx Procedure string-capitalize str +The obvious string conversion routines. These are non-destructive. +@end deffn + +@defun string-upcase! str +@defunx string-downcase! str +@defunx string-captialize! str +The destructive versions of the functions above. +@end defun + + + + + +@node String Ports, String Search, String-Case, Procedures +@section String Ports + +@code{(require 'string-port)} + +@deffn Procedure call-with-output-string proc +@var{proc} must be a procedure of one argument. This procedure calls +@var{proc} with one argument: a (newly created) output port. When the +function returns, the string composed of the characters written into the +port is returned.@refill +@end deffn + +@deffn Procedure call-with-input-string string proc +@var{proc} must be a procedure of one argument. This procedure calls +@var{proc} with one argument: an (newly created) input port from which +@var{string}'s contents may be read. When @var{proc} returns, the port +is closed and the value yielded by the procedure @var{proc} is +returned.@refill +@end deffn + + +@node String Search, Tektronix Graphics Support, String Ports, Procedures +@section String Search + +@code{(require 'string-search)} + +@deffn Procedure string-index string char +Returns the index of the first occurence of @var{char} within +@var{string}, or @code{#f} if the @var{string} does not contain a +character @var{char}. +@end deffn + +@deffn procedure substring? pattern string +Searches @var{string} to see if some substring of @var{string} is equal +to @var{pattern}. @code{substring?} returns the index of the first +character of the first substring of @var{string} that is equal to +@var{pattern}; or @code{#f} if @var{string} does not contain +@var{pattern}. + +@example +(substring? "rat" "pirate") @result{} 2 +(substring? "rat" "outrage") @result{} #f +(substring? "" any-string) @result{} 0 +@end example +@end deffn + +@deffn Procedure find-string-from-port? str in-port max-no-chars +@deffnx Procedure find-string-from-port? str in-port +Looks for a string @var{str} within the first @var{max-no-chars} chars +of the input port @var{in-port}. @var{max-no-chars} may be omitted: in +that case, the search span is limited by the end of the input stream. +When the @var{str} is found, the function returns the number of +characters it has read from the port, and the port is set to read the +first char after that (that is, after the @var{str}) The function +returns @code{#f} when the @var{str} isn't found. + +@code{find-string-from-port?} reads the port @emph{strictly} +sequentially, and does not perform any buffering. So +@code{find-string-from-port?} can be used even if the @var{in-port} is +open to a pipe or other communication channel. +@end deffn + + +@node Tektronix Graphics Support, Tree Operations, String Search, Procedures +@section Tektronix Graphics Support + +@emph{Note:} The Tektronix graphics support files need more work, and +are not complete. + +@subsection Tektronix 4000 Series Graphics + +The Tektronix 4000 series graphics protocol gives the user a 1024 by +1024 square drawing area. The origin is in the lower left corner of the +screen. Increasing y is up and increasing x is to the right. + +The graphics control codes are sent over the current-output-port and can +be mixed with regular text and ANSI or other terminal control sequences. + +@deffn Procedure tek40:init +@end deffn + +@deffn Procedure tek40:graphics +@end deffn + +@deffn Procedure tek40:text +@end deffn + +@deffn Procedure tek40:linetype linetype +@end deffn + +@deffn Procedure tek40:move x y +@end deffn + +@deffn Procedure tek40:draw x y +@end deffn + +@deffn Procedure tek40:put-text x y str +@end deffn + +@deffn Procedure tek40:reset +@end deffn + + +@subsection Tektronix 4100 Series Graphics + +The graphics control codes are sent over the current-output-port and can +be mixed with regular text and ANSI or other terminal control sequences. + +@deffn Procedure tek41:init +@end deffn + +@deffn Procedure tek41:reset +@end deffn + +@deffn Procedure tek41:graphics +@end deffn + +@deffn Procedure tek41:move x y +@end deffn + +@deffn Procedure tek41:draw x y +@end deffn + +@deffn Procedure tek41:point x y number +@end deffn + +@deffn Procedure tek41:encode-x-y x y +@end deffn + +@deffn Procedure tek41:encode-int number +@end deffn + + + +@node Tree Operations, , Tektronix Graphics Support, Procedures +@section Tree operations + +@code{(require 'tree)} + +These are operations that treat lists a representations of trees. + +@defun subst new old tree +@defunx substq new old tree +@defunx substv new old tree +@code{subst} makes a copy of @var{tree}, substituting @var{new} for +every subtree or leaf of @var{tree} which is @code{equal?} to @var{old} +and returns a modified tree. The original @var{tree} is unchanged, but +may share parts with the result.@refill + +@code{substq} and @code{substv} are similar, but test against @var{old} +using @code{eq?} and @code{eqv?} respectively.@refill + +Examples: +@lisp +(substq 'tempest 'hurricane '(shakespeare wrote (the hurricane))) + @result{} (shakespeare wrote (the tempest)) +(substq 'foo '() '(shakespeare wrote (twelfth night))) + @result{} (shakespeare wrote (twelfth night . foo) . foo) +(subst '(a . cons) '(old . pair) + '((old . spice) ((old . shoes) old . pair) (old . pair))) + @result{} ((old . spice) ((old . shoes) a . cons) (a . cons)) +@end lisp +@end defun + +@defun copy-tree tree +Makes a copy of the nested list structure @var{tree} using new pairs and +returns it. All levels are copied, so that none of the pairs in the +tree are @code{eq?} to the original ones -- only the leaves are.@refill + +Example: +@lisp +(define bar '(bar)) +(copy-tree (list bar 'foo)) + @result{} ((bar) foo) +(eq? bar (car (copy-tree (list bar 'foo)))) + @result{} #f +@end lisp +@end defun + + + + + +@node Standards Support, Session Support, Procedures, Top +@chapter Standards Support + + + +@menu +* With-File:: 'with-file +* Transcripts:: 'transcript +* Rev2 Procedures:: 'rev2-procedures +* Rev4 Optional Procedures:: 'rev4-optional-procedures +* Multi-argument / and -:: 'multiarg/and- +* Multi-argument Apply:: 'multiarg-apply +* Rationalize:: 'rationalize +* Promises:: 'promise +* Dynamic-Wind:: 'dynamic-wind +* Values:: 'values +* Time:: 'time +* CLTime:: 'common-lisp-time +@end menu + +@node With-File, Transcripts, Standards Support, Standards Support +@section With-File + +@code{(require 'with-file)} + +@defun with-input-from-file file thunk +@defunx with-output-to-file file thunk +Description found in R4RS. +@end defun + +@node Transcripts, Rev2 Procedures, With-File, Standards Support +@section Transcripts + +@code{(require 'transcript)} + +@defun transcript-on filename +@defunx transcript-off filename +Redefines @code{read-char}, @code{read}, @code{write-char}, +@code{write}, @code{display}, and @code{newline}.@refill +@end defun + + + + + +@node Rev2 Procedures, Rev4 Optional Procedures, Transcripts, Standards Support +@section Rev2 Procedures + +@code{(require 'rev2-procedures)} + +The procedures below were specified in the @cite{Revised^2 Report on +Scheme}. @strong{N.B.}: The symbols @code{1+} and @code{-1+} are not +@cite{R4RS} syntax. Scheme->C, for instance, barfs on this +module.@refill + +@deffn Procedure substring-move-left! string1 start1 end1 string2 start2 +@deffnx Procedure substring-move-right! string1 start1 end1 string2 start2 +@var{string1} and @var{string2} must be a strings, and @var{start1}, +@var{start2} and @var{end1} must be exact integers satisfying@refill + +@display +0 <= @var{start1} <= @var{end1} <= (string-length @var{string1}) +0 <= @var{start2} <= @var{end1} - @var{start1} + @var{start2} <= (string-length @var{string2}) +@end display + +@code{substring-move-left!} and @code{substring-move-right!} store +characters of @var{string1} beginning with index @var{start1} +(inclusive) and ending with index @var{end1} (exclusive) into +@var{string2} beginning with index @var{start2} (inclusive).@refill + +@code{substring-move-left!} stores characters in time order of +increasing indices. @code{substring-move-right!} stores characters in +time order of increasing indeces.@refill +@end deffn + +@deffn Procedure substring-fill! string start end char +Fills the elements @var{start}--@var{end} of @var{string} with the +character @var{char}.@refill +@end deffn + +@defun string-null? str +@equiv{} @code{(= 0 (string-length @var{str}))} +@end defun + +@deffn Procedure append! . pairs +Destructively appends its arguments. Equivalent to @code{nconc}. +@end deffn + +@defun 1+ n +Adds 1 to @var{n}. +@end defun + +@defun -1+ n +Subtracts 1 from @var{n}. +@end defun + +@defun ? +@defunx >=? +These are equivalent to the procedures of the same name but without the +trailing @samp{?}. +@end defun + + + +@node Rev4 Optional Procedures, Multi-argument / and -, Rev2 Procedures, Standards Support +@section Rev4 Optional Procedures + +@code{(require 'rev4-optional-procedures)} + +For the specification of these optional procedures, +@xref{Standard procedures, , ,r4rs, Revised(4) Scheme}. + +@defun list-tail l p +@end defun + +@defun string->list s +@end defun + +@defun list->string l +@end defun + +@defun string-copy +@end defun + +@deffn Procedure string-fill! s obj +@end deffn + +@defun list->vector l +@end defun + +@defun vector->list s +@end defun + +@deffn Procedure vector-fill! s obj +@end deffn + + + + + +@node Multi-argument / and -, Multi-argument Apply, Rev4 Optional Procedures, Standards Support +@section Multi-argument / and - + +@code{(require 'mutliarg/and-)} + +For the specification of these optional forms, @xref{Numerical +operations, , ,r4rs, Revised(4) Scheme}. The @code{two-arg:}* forms are +only defined if the implementation does not support the many-argument +forms.@refill + +@defun two-arg:/ n1 n2 +The original two-argument version of @code{/}. +@end defun + +@defun / divident . divisors +@end defun + +@defun two-arg:- n1 n2 +The original two-argument version of @code{-}. +@end defun + +@defun - minuend . subtrahends +@end defun + + + + + +@node Multi-argument Apply, Rationalize, Multi-argument / and -, Standards Support +@section Multi-argument Apply + +@code{(require 'multiarg-apply)} + +@noindent +For the specification of this optional form, +@xref{Control features, , ,r4rs, Revised(4) Scheme}. + +@defun two-arg:apply proc l +The implementation's native @code{apply}. Only defined for +implementations which don't support the many-argument version. +@end defun + +@defun apply proc . args +@end defun + + + + + +@node Rationalize, Promises, Multi-argument Apply, Standards Support +@section Rationalize + +@code{(require 'rationalize)} + +The procedure rationalize is interesting because most programming +languages do not provide anything analogous to it. For simplicity, we +present an algorithm which computes the correct result for exact +arguments (provided the implementation supports exact rational numbers +of unlimited precision), and produces a reasonable answer for inexact +arguments when inexact arithmetic is implemented using floating-point. +We thank Alan Bawden for contributing this algorithm. + +@defun rationalize x e +@end defun + + + + + +@node Promises, Dynamic-Wind, Rationalize, Standards Support +@section Promises + +@code{(require 'promise)} + +@defun make-promise proc +@end defun + +Change occurrences of @code{(delay @var{expression})} to +@code{(make-promise (lambda () @var{expression}))} and @code{(define +force promise:force)} to implement promises if your implementation +doesn't support them +(@pxref{Control features, , ,r4rs, Revised(4) Scheme}). + + + + +@node Dynamic-Wind, Values, Promises, Standards Support +@section Dynamic-Wind + +@code{(require 'dynamic-wind)} + +This facility is a generalization of Common LISP @code{unwind-protect}, +designed to take into account the fact that continuations produced by +@code{call-with-current-continuation} may be reentered.@refill + +@deffn Procedure dynamic-wind thunk1 thunk2 thunk3 +The arguments @var{thunk1}, @var{thunk2}, and @var{thunk3} must all be +procedures of no arguments (thunks).@refill + +@code{dynamic-wind} calls @var{thunk1}, @var{thunk2}, and then +@var{thunk3}. The value returned by @var{thunk2} is returned as the +result of @code{dynamic-wind}. @var{thunk3} is also called just before +control leaves the dynamic context of @var{thunk2} by calling a +continuation created outside that context. Furthermore, @var{thunk1} is +called before reentering the dynamic context of @var{thunk2} by calling +a continuation created inside that context. (Control is inside the +context of @var{thunk2} if @var{thunk2} is on the current return stack). + +@strong{Warning:} There is no provision for dealing with errors or +interrupts. If an error or interrupt occurs while using +@code{dynamic-wind}, the dynamic environment will be that in effect at +the time of the error or interrupt.@refill +@end deffn + + + + +@node Values, Time, Dynamic-Wind, Standards Support +@section Values + +@code{(require 'values)} + +@defun values obj @dots{} +@code{values} takes any number of arguments, and passes (returns) them +to its continuation.@refill +@end defun + + +@defun call-with-values thunk proc +@var{thunk} must be a procedure of no arguments, and @var{proc} must be +a procedure. @code{call-with-values} calls @var{thunk} with a +continuation that, when passed some values, calls @var{proc} with those +values as arguments.@refill + +Except for continuations created by the @code{call-with-values} +procedure, all continuations take exactly one value, as now; the effect +of passing no value or more than one value to continuations that were +not created by the @code{call-with-values} procedure is +unspecified.@refill +@end defun + +@node Time, CLTime, Values, Standards Support +@section Time + +The procedures @code{current-time}, @code{difftime}, and +@code{offset-time} are supported by all implementations (SLIB provides +them if feature @code{('current-time)} is missing. @code{current-time} +returns a @dfn{calendar time} (caltime) which can be a number or other +type. + +@defun current-time +Returns the time since 00:00:00 GMT, January 1, 1970, measured in +seconds. Note that the reference time is different from the reference +time for @code{get-universal-time} in @ref{CLTime}. On implementations +which cannot support actual times, @code{current-time} will increment a +counter and return its value when called. +@end defun + +@defun difftime caltime1 caltime0 +Returns the difference (number of seconds) between twe calendar times: +@var{caltime1} - @var{caltime0}. @var{caltime0} can also be a number. +@end defun + +@defun offset-time caltime offset +Returns the calendar time of @var{caltime} offset by @var{offset} number +of seconds @code{(+ caltime offset)}. +@end defun + +@example +(require 'posix-time) +@end example + +These procedures are intended to be compatible with Posix time +conversion functions. + +@defvar *timezone* +contains the difference, in seconds, between UTC and local standard time +(for example, in the U.S. Eastern time zone (EST), timezone is +5*60*60). @code{*timezone*} is initialized by @code{tzset}. +@end defvar + +@defun tzset +initializes the @var{*timezone*} variable from the TZ environment +variable. This function is automatically called by the other time +conversion functions that depend on the time zone. +@end defun + +@defun gmtime caltime +converts the calendar time @var{caltime} to a vector of integers +representing the time expressed as Coordinated Universal Time (UTC). + +@defunx localtime caltime +converts the calendar time @var{caltime} to a vector of integers expressed +relative to the user's time zone. @code{localtime} sets the variable +@var{*timezone*} with the difference between Coordinated Universal Time +(UTC) and local standard time in seconds by calling @code{tzset}. +The elements of the returned vector are as follows: + +@enumerate 0 +@item + seconds (0 - 61) +@item + minutes (0 - 59) +@item + hours since midnight +@item + day of month +@item + month (0 - 11). Note difference from @code{decode-universal-time}. +@item + year (A.D.) +@item + day of week (0 - 6) +@item + day of year (0 - 365) +@item + 1 for daylight savings, 0 for regular time +@end enumerate +@end defun + +@defun mktime univtime +Converts a vector of integers in Coordinated Universal Time (UTC) format +to calendar time (caltime) format. +@end defun + +@defun asctime univtime +Converts the vector of integers @var{caltime} in Coordinated +Universal Time (UTC) format into a string of the form +@code{"Wed Jun 30 21:49:08 1993"}. +@end defun + +@defun ctime caltime +Equivalent to @code{(time:asctime (time:localtime @var{caltime}))}. +@end defun + +@node CLTime, , Time, Standards Support +@section CLTime + +@defun get-decoded-time +Equivalent to @code{(decode-universal-time (get-universal-time))}. +@end defun + +@defun get-universal-time +Returns the current time as @dfn{Universal Time}, number of seconds +since 00:00:00 Jan 1, 1900 GMT. Note that the reference time is +different from @code{current-time}. +@end defun + +@defun decode-universal-time univtime +Converts @var{univtime} to @dfn{Decoded Time} format. +Nine values are returned: +@enumerate 0 +@item + seconds (0 - 61) +@item + minutes (0 - 59) +@item + hours since midnight +@item + day of month +@item + month (1 - 12). Note difference from @code{gmtime} and @code{localtime}. +@item + year (A.D.) +@item + day of week (0 - 6) +@item + #t for daylight savings, #f otherwise +@item + hours west of GMT (-24 - +24) +@end enumerate + +Notice that the values returned by @code{decode-universal-time} do not +match the arguments to @code{encode-universal-time}. +@end defun + +@defun encode-universal-time second minute hour date month year +@defunx encode-universal-time second minute hour date month year time-zone +Converts the arguments in Decoded Time format to Universal Time format. +If @var{time-zone} is not specified, the returned time is adjusted for +daylight saving time. Otherwise, no adjustment is performed. + +Notice that the values returned by @code{decode-universal-time} do not +match the arguments to @code{encode-universal-time}. +@end defun + + +@node Session Support, Optional SLIB Packages, Standards Support, Top +@chapter Session Support + +@menu +* Repl:: Macros at top-level +* Quick Print:: Loop-safe Output +* Debug:: To err is human ... +* Breakpoints:: Pause execution +* Trace:: 'trace +* Getopt:: Command Line option parsing +* Command Line:: A command line reader for Scheme shells +* System Interface:: 'system and 'getenv + +Certain features are so simple, system-dependent, or widely subcribed +that they are supported by all implementations as part of the +@samp{*.init} files. + +The features described in the following sections are provided by all +implementations. + +* Require:: Module Management +* Vicinity:: Pathname Management +* Configuration:: Characteristics of Scheme Implementation +* Input/Output:: Things not provided by the Scheme specs. +* Legacy:: +* System:: LOADing, EVALing, ERRORing, and EXITing +@end menu + + + +@node Repl, Quick Print, Session Support, Session Support +@section Repl + +@code{(require 'repl)} + +Here is a read-eval-print-loop which, given an eval, evaluates forms. + +@deffn Procedure repl:top-level repl:eval +@code{read}s, @code{repl:eval}s and @code{write}s expressions from +@code{(current-input-port)} to @code{(current-output-port)} until an +end-of-file is encountered. @code{load}, @code{slib:eval}, +@code{slib:error}, and @code{repl:quit} dynamically bound during +@code{repl:top-level}.@refill +@end deffn + +@deffn Procedure repl:quit +Exits from the invocation of @code{repl:top-level}. +@end deffn + +The @code{repl:} procedures establish, as much as is possible to do +portably, a top level environment supporting macros. +@code{repl:top-level} uses @code{dynamic-wind} to catch error conditions +and interrupts. If your implementation supports this you are all set. + +Otherwise, if there is some way your implementation can catch error +conditions and interrupts, then have them call @code{slib:error}. It +will display its arguments and reenter @code{repl:top-level}. +@code{slib:error} dynamically bound by @code{repl:top-level}.@refill + +To have your top level loop always use macros, add any interrupt +catching lines and the following lines to your Scheme init file: +@lisp +(require 'macro) +(require 'repl) +(repl:top-level macro:eval) +@end lisp + +@node Quick Print, Debug, Repl, Session Support +@section Quick Print + +@code{(require 'qp)} + +@noindent +When displaying error messages and warnings, it is paramount that the +output generated for circular lists and large data structures be +limited. This section supplies a procedure to do this. It could be +much improved. + +@quotation +Notice that the neccessity for truncating output eliminates +Common-Lisp's @xref{Format} from consideration; even when variables +@code{*print-level*} and @code{*print-level*} are set, huge strings and +bit-vectors are @emph{not} limited. +@end quotation + +@deffn Procedure qp arg1 @dots{} +@deffnx Procedure qpn arg1 @dots{} +@deffnx Procedure qpr arg1 @dots{} +@code{qp} writes its arguments, separated by spaces, to +@code{(current-output-port)}. @code{qp} compresses printing by +substituting @samp{...} for substructure it does not have sufficient +room to print. @code{qpn} is like @code{qp} but outputs a newline +before returning. @code{qpr} is like @code{qpn} except that it returns +its last argument.@refill +@end deffn + +@defvar *qp-width* +@code{*qp-width*} is the largest number of characters that @code{qp} +should use.@refill +@end defvar + +@node Debug, Breakpoints, Quick Print, Session Support +@section Debug + +@code{(require 'debug)} + +@noindent +Requiring @code{debug} automatically requires @code{trace} and +@code{break}. + +@noindent +An application with its own datatypes may want to substitute its own +printer for @code{qp}. This example shows how to do this: + +@example +(define qpn (lambda args) @dots{}) +(provide 'qp) +(require 'debug) +@end example + +@deffn Procedure trace-all file +Traces (@pxref{Trace}) all procedures @code{define}d at top-level in +file @file{file}. +@end deffn + +@deffn Procedure break-all file +Breakpoints (@pxref{Breakpoints}) all procedures @code{define}d at +top-level in file @file{file}. +@end deffn + +@node Breakpoints, Trace, Debug, Session Support +@section Breakpoints + +@code{(require 'break)} + +@defun init-debug +If your Scheme implementation does not support @code{break} or +@code{abort}, a message will appear when you @code{(require 'break)} or +@code{(require 'debug)} telling you to type @code{(init-debug)}. This +is in order to establish a top-level continuation. Typing +@code{(init-debug)} at top level sets up a continuation for +@code{break}. +@end defun + +@defun breakpoint arg1 @dots{} +Returns from the top level continuation and pushes the continuation from +which it was called on a continuation stack. +@end defun + +@defun continue +Pops the topmost continuation off of the continuation stack and returns +an unspecified value to it. +@defunx continue arg1 @dots{} +Pops the topmost continuation off of the continuation stack and returns +@var{arg1} @dots{} to it. +@end defun + +@defmac break proc1 @dots{} +Redefines the top-level named procedures given as arguments so that +@code{breakpoint} is called before calling @var{proc1} @dots{}. +@defmacx break +With no arguments, makes sure that all the currently broken identifiers +are broken (even if those identifiers have been redefined) and returns a +list of the broken identifiers. +@end defmac + +@defmac unbreak proc1 @dots{} +Turns breakpoints off for its arguments. +@defmacx unbreak +With no arguments, unbreaks all currently broken identifiers and returns +a list of these formerly broken identifiers. +@end defmac + +The following routines are the procedures which actually do the tracing +when this module is supplied by SLIB, rather than natively. If +defmacros are not natively supported by your implementation, these might +be more convenient to use. + +@defun breakf proc +@defunx breakf proc name +@defunx debug:breakf proc +@defunx debug:breakf proc name +To break, type +@lisp +(set! @var{symbol} (breakf @var{symbol})) +@end lisp +@noindent +or +@lisp +(set! @var{symbol} (breakf @var{symbol} '@var{symbol})) +@end lisp +@noindent +or +@lisp +(define @var{symbol} (breakf @var{function})) +@end lisp +@noindent +or +@lisp +(define @var{symbol} (breakf @var{function} '@var{symbol})) +@end lisp +@end defun + +@defun unbreakf proc +@defunx debug:unbreakf proc +To unbreak, type +@lisp +(set! @var{symbol} (unbreakf @var{symbol})) +@end lisp +@end defun + +@node Trace, Getopt, Breakpoints, Session Support +@section Tracing + +@code{(require 'trace)} + +@defmac trace proc1 @dots{} +Traces the top-level named procedures given as arguments. +@defmacx trace +With no arguments, makes sure that all the currently traced identifiers +are traced (even if those identifiers have been redefined) and returns a +list of the traced identifiers. +@end defmac + +@defmac untrace proc1 @dots{} +Turns tracing off for its arguments. +@defmacx untrace +With no arguments, untraces all currently traced identifiers and returns +a list of these formerly traced identifiers. +@end defmac + +The following routines are the procedures which actually do the tracing +when this module is supplied by SLIB, rather than natively. If +defmacros are not natively supported by your implementation, these might +be more convenient to use. + +@defun tracef proc +@defunx tracef proc name +@defunx debug:tracef proc +@defunx debug:tracef proc name +To trace, type +@lisp +(set! @var{symbol} (tracef @var{symbol})) +@end lisp +@noindent +or +@lisp +(set! @var{symbol} (tracef @var{symbol} '@var{symbol})) +@end lisp +@noindent +or +@lisp +(define @var{symbol} (tracef @var{function})) +@end lisp +@noindent +or +@lisp +(define @var{symbol} (tracef @var{function} '@var{symbol})) +@end lisp +@end defun + +@defun untracef proc +@defunx debug:untracef proc +To untrace, type +@lisp +(set! @var{symbol} (untracef @var{symbol})) +@end lisp +@end defun + + +@node Getopt, Command Line, Trace, Session Support +@section Getopt + +@code{(require 'getopt)} + +This routine implements Posix command line argument parsing. Notice +that returning values through global variables means that @code{getopt} +is @emph{not} reentrant. + +@defvar *optind* +Is the index of the current element of the command line. It is +initially one. In order to parse a new command line or reparse an old +one, @var{*opting*} must be reset. +@end defvar + +@defvar *optarg* +Is set by getopt to the (string) option-argument of the current option. +@end defvar + +@deffn Procedure getopt argc argv optstring +Returns the next option letter in @var{argv} (starting from +@code{(vector-ref argv *optind*)}) that matches a letter in +@var{optstring}. @var{argv} is a vector or list of strings, the 0th of +which getopt usually ignores. @var{argc} is the argument count, usually +the length of @var{argv}. @var{optstring} is a string of recognized +option characters; if a character is followed by a colon, the option +takes an argument which may be immediately following it in the string or +in the next element of @var{argv}. + +@var{*optind*} is the index of the next element of the @var{argv} vector +to be processed. It is initialized to 1 by @file{getopt.scm}, and +@code{getopt} updates it when it finishes with each element of +@var{argv}. + +@code{getopt} returns the next option character from @var{argv} that +matches a character in @var{optstring}, if there is one that matches. +If the option takes an argument, @code{getopt} sets the variable +@var{*optarg*} to the option-argument as follows: + +@itemize @bullet +@item +If the option was the last character in the string pointed to by an +element of @var{argv}, then @var{*optarg*} contains the next element of +@var{argv}, and @var{*optind*} is incremented by 2. If the resulting +value of @var{*optind*} is greater than or equal to @var{argc}, this +indicates a missing option argument, and @code{getopt} returns an error +indication. + +@item +Otherwise, @var{*optarg*} is set to the string following the option +character in that element of @var{argv}, and @var{*optind*} is +incremented by 1. +@end itemize + +If, when @code{getopt} is called, the string @code{(vector-ref argv +*optind*)} either does not begin with the character @code{#\-} or is +just @code{"-"}, @code{getopt} returns @code{#f} without changing +@var{*optind*}. If @code{(vector-ref argv *optind*)} is the string +@code{"--"}, @code{getopt} returns @code{#f} after incrementing +@var{*optind*}. + +If @code{getopt} encounters an option character that is not contained in +@var{optstring}, it returns the question-mark @code{#\?} character. If +it detects a missing option argument, it returns the colon character +@code{#\:} if the first character of @var{optstring} was a colon, or a +question-mark character otherwise. In either case, @code{getopt} sets +the variable @var{getopt:opt} to the option character that caused the +error. + +The special option @code{"--"} can be used to delimit the end of the +options; @code{#f} is returned, and @code{"--"} is skipped. + +RETURN VALUE + +@code{getopt} returns the next option character specified on the command +line. A colon @code{#\:} is returned if @code{getopt} detects a missing argument +and the first character of @var{optstring} was a colon @code{#\:}. + +A question-mark @code{#\?} is returned if @code{getopt} encounters an option +character not in @var{optstring} or detects a missing argument and the first +character of @var{optstring} was not a colon @code{#\:}. + +Otherwise, @code{getopt} returns @code{#f} when all command line options have been +parsed. + +Example: +@lisp +#! /usr/local/bin/scm +;;;This code is SCM specific. +(define argv (program-arguments)) +(require 'getopt) + +(define opts ":a:b:cd") +(let loop ((opt (getopt (length argv) argv opts))) + (case opt + ((#\a) (print "option a: " *optarg*)) + ((#\b) (print "option b: " *optarg*)) + ((#\c) (print "option c")) + ((#\d) (print "option d")) + ((#\?) (print "error" getopt:opt)) + ((#\:) (print "missing arg" getopt:opt)) + ((#f) (if (< *optind* (length argv)) + (print "argv[" *optind* "]=" + (list-ref argv *optind*))) + (set! *optind* (+ *optind* 1)))) + (if (< *optind* (length argv)) + (loop (getopt (length argv) argv opts)))) + +(slib:exit) +@end lisp +@end deffn + +@section Getopt-- + +@defun getopt-- argc argv optstring +The procedure @code{getopt--} is an extended version of @code{getopt} +which parses @dfn{long option names} of the form +@samp{--hold-the-onions} and @samp{--verbosity-level=extreme}. +@w{@code{Getopt--}} behaves as @code{getopt} except for non-empty +options beginning with @samp{--}. + +Options beginning with @samp{--} are returned as strings rather than +characters. If a value is assigned (using @samp{=}) to a long option, +@code{*optarg*} is set to the value. The @samp{=} and value are +not returned as part of the option string. + +No information is passed to @code{getopt--} concerning which long +options should be accepted or whether such options can take arguments. +If a long option did not have an argument, @code{*optarg} will be set to +@code{#f}. The caller is responsible for detecting and reporting +errors. + +@example +(define opts ":-:b:") +(define argc 5) +(define argv '("foo" "-b9" "--f1" "--2=" "--g3=35234.342" "--")) +(define *optind* 1) +(define *optarg* #f) +(require 'qp) +(do ((i 5 (+ -1 i))) + ((zero? i)) + (define opt (getopt-- argc argv opts)) + (print *optind* opt *optarg*))) +@print{} +2 #\b "9" +3 "f1" #f +4 "2" "" +5 "g3" "35234.342" +5 #f "35234.342" +@end example +@end defun + +@node Command Line, System Interface, Getopt, Session Support +@section Command Line + +@code{(require 'read-command)} + +@defun read-command port +@defunx read-command +@code{read-command} converts a @dfn{command line} into a list of strings +suitable for parsing by @code{getopt}. The syntax of command lines +supported resembles that of popular @dfn{shell}s. @code{read-command} +updates @var{port} to point to the first character past the command +delimiter. + +If an end of file is encountered in the input before any characters are +found that can begin an object or comment, then an end of file object is +returned. + +The @var{port} argument may be omitted, in which case it defaults to the +value returned by @code{current-input-port}. + +The fields into which the command line is split are delimited by +whitespace as defined by @code{char-whitespace?}. The end of a command +is delimited by end-of-file or unescaped semicolon (@key{;}) or +@key{newline}. Any character can be literally included in a field by +escaping it with a backslach (@key{\}). + +The initial character and types of fields recognized are: +@table @asis +@item @samp{\} +The next character has is taken literally and not interpreted as a field +delimiter. If @key{\} is the last character before a @key{newline}, +that @key{newline} is just ignored. Processing continues from the +characters after the @key{newline} as though the backslash and +@key{newline} were not there. +@item @samp{"} +The characters up to the next unescaped @key{"} are taken literally, +according to [R4RS] rules for literal strings (@pxref{Strings, , ,r4rs, +Revised(4) Scheme}). +@item @samp{(}, @samp{%'} +One scheme expression is @code{read} starting with this character. The +@code{read} expression is evaluated, converted to a string +(using @code{display}), and replaces the expression in the returned +field. +@item @samp{;} +Semicolon delimits a command. Using semicolons more than one command +can appear on a line. Escaped semicolons and semicolons inside strings +do not delimit commands. +@end table + +@noindent +The comment field differs from the previous fields in that it must be +the first character of a command or appear after whitespace in order to +be recognized. @key{#} can be part of fields if these conditions are +not met. For instance, @code{ab#c} is just the field ab#c. + +@table @samp +@item # +Introduces a comment. The comment continues to the end of the line on +which the semicolon appears. Comments are treated as whitespace by +@code{read-dommand-line} and backslashes before @key{newline}s in +comments are also ignored. +@end table +@end defun + +@node System Interface, Require, Command Line, Session Support +@section System Interface + +If @code{(provided? 'getenv)}: + +@defun getenv name +Looks up @var{name}, a string, in the program environment. If @var{name} is +found a string of its value is returned. Otherwise, @code{#f} is returned. +@end defun + +If @code{(provided? 'system)}: + +@defun system command-string +Executes the @var{command-string} on the computer and returns the +integer status code. +@end defun + + +@node Require, Vicinity, System Interface, Session Support +@section Require + +These variables and procedures are provided by all implementations. + +@defvar *features* +Is a list of symbols denoting features supported in this implementation. +@end defvar + +@defvar *modules* +Is a list of pathnames denoting files which have been loaded. +@end defvar + +@defvar *catalog* +Is an association list of features (symbols) and pathnames which will +supply those features. The pathname can be either a string or a pair. +If pathname is a pair then the first element should be a macro feature +symbol, @code{source}, or @code{compiled}. The cdr of the pathname +should be either a string or a list. +@end defvar + +In the following three functions if @var{feature} is not a symbol it is +assumed to be a pathname.@refill + +@defun provided? feature +Returns @code{#t} if @var{feature} is a member of @code{*features*} or +@code{*modules*} or if @var{feature} is supported by a file already +loaded and @code{#f} otherwise.@refill +@end defun + +@deffn Procedure require feature +If @code{(not (provided? @var{feature}))} it is loaded if @var{feature} +is a pathname or if @code{(assq @var{feature} *catalog*)}. Otherwise an +error is signaled.@refill +@end deffn + +@deffn Procedure provide feature +Assures that @var{feature} is contained in @code{*features*} if +@var{feature} is a symbol and @code{*modules*} otherwise.@refill +@end deffn + +@defun require:feature->path feature +Returns @code{#t} if @var{feature} is a member of @code{*features*} or +@code{*modules*} or if @var{feature} is supported by a file already +loaded. Returns a path if one was found in @code{*catalog*} under the +feature name, and @code{#f} otherwise. The path can either be a string +suitable as an argument to load or a pair as described above for +*catalog*. +@end defun + +Below is a list of features that are automatically determined by +@code{require}. For each item, @code{(provided? '@var{feature})} will +return @code{#t} if that feature is available, and @code{#f} if +not.@refill + +@itemize @bullet +@item +'inexact +@item +'rational +@item +'real +@item +'complex +@item +'bignum +@end itemize + + + + + +@node Vicinity, Configuration, Require, Session Support +@section Vicinity + +A vicinity is a descriptor for a place in the file system. Vicinities +hide from the programmer the concepts of host, volume, directory, and +version. Vicinities express only the concept of a file environment +where a file name can be resolved to a file in a system independent +manner. Vicinities can even be used on @dfn{flat} file systems (which +have no directory structure) by having the vicinity express constraints +on the file name. On most systems a vicinity would be a string. All of +these procedures are file system dependent. + +These procedures are provided by all implementations. + +@defun make-vicinity filename +Returns the vicinity of @var{filename} for use by @code{in-vicinity}. +@end defun + +@defun program-vicinity +Returns the vicinity of the currently loading Scheme code. For an +interpreter this would be the directory containing source code. For a +compiled system (with multiple files) this would be the directory where +the object or executable files are. If no file is currently loading it +the result is undefined. @strong{Warning:} @code{program-vicinity} can +return incorrectl values if your program escapes back into a +@code{load}.@refill +@end defun + +@defun library-vicinity +Returns the vicinity of the shared Scheme library. +@end defun + +@defun implementation-vicinity +Returns the vicinity of the underlying Scheme implementation. This +vicinity will likely contain startup code and messages and a compiler. +@end defun + +@defun user-vicinity +Returns the vicinity of the current directory of the user. On most +systems this is @file{""} (the empty string). +@end defun + +@c @defun scheme-file-suffix +@c Returns the default filename suffix for scheme source files. On most +@c systems this is @samp{.scm}.@refill +@c @end defun + +@defun in-vicinity vicinity filename +Returns a filename suitable for use by @code{slib:load}, +@code{slib:load-source}, @code{slib:load-compiled}, +@code{open-input-file}, @code{open-output-file}, etc. The returned +filename is @var{filename} in @var{vicinity}. @code{in-vicinity} should +allow @var{filename} to override @var{vicinity} when @var{filename} is +an absolute pathname and @var{vicinity} is equal to the value of +@code{(user-vicinity)}. The behavior of @code{in-vicinity} when +@var{filename} is absolute and @var{vicinity} is not equal to the value +of @code{(user-vicinity)} is unspecified. For most systems +@code{in-vicinity} can be @code{string-append}.@refill +@end defun + +@defun sub-vicinity vicinity name +Returns the vicinity of @var{vicinity} restricted to @var{name}. This +is used for large systems where names of files in subsystems could +conflict. On systems with directory structure @code{sub-vicinity} will +return a pathname of the subdirectory @var{name} of +@var{vicinity}.@refill +@end defun + + + +@node Configuration, Input/Output, Vicinity, Session Support +@section Configuration + +These constants and procedures describe characteristics of the Scheme +and underlying operating system. They are provided by all +implementations. + +@defvr Constant char-code-limit +An integer 1 larger that the largest value which can be returned by +@code{char->integer}.@refill +@end defvr + +@defvr Constant most-positive-fixnum +The immediate integer closest to positive infinity. +@end defvr + +@defvr Constant slib:tab +The tab character. +@end defvr + +@defvr Constant slib:form-feed +The form-feed character. +@end defvr + +@defun software-type +Returns a symbol denoting the generic operating system type. For +instance, @code{unix}, @code{vms}, @code{macos}, @code{amiga}, or +@code{ms-dos}. +@end defun + +@defun slib:report-version +Displays the versions of SLIB and the underlying Scheme implementation +and the name of the operating system. An unspecified value is returned. + +@example +(slib:report-version) @result{} slib "2a3" on scm "4e1" on unix +@end example +@end defun + +@defun slib:report +Displays the information of @code{(slib:report-version)} followed by +almost all the information neccessary for submitting a problem report. +An unspecified value is returned. + +@defunx slib:report #t +provides a more verbose listing. + +@defunx slib:report filename +Writes the report to file @file{filename}. + +@example +(slib:report) +@result{} +slib "2a3" on scm "4e1" on unix +(implementation-vicinity) is "/usr/local/src/scm/" +(library-vicinity) is "/usr/local/lib/slib/" +(scheme-file-suffix) is ".scm" +implementation *features* : + bignum complex real rational + inexact vicinity ed getenv + tmpnam system abort transcript + with-file ieee-p1178 rev4-report rev4-optional-procedures + hash object-hash delay eval + dynamic-wind multiarg-apply multiarg/and- logical + defmacro string-port source array-for-each + array full-continuation char-ready? line-i/o + i/o-extensions pipe +implementation *catalog* : + (rev4-optional-procedures . "/usr/local/lib/slib/sc4opt") + ... +@end example +@end defun + +@node Input/Output, Legacy, Configuration, Session Support +@section Input/Output + +These procedures are provided by all implementations. + +@deffn Procedure file-exists? filename +Returns @code{#t} if the specified file exists. Otherwise, returns +@code{#f}. If the underlying implementation does not support this +feature then @code{#f} is always returned. +@end deffn + +@deffn Procedure delete-file filename +Deletes the file specified by @var{filename}. If @var{filename} can not +be deleted, @code{#f} is returned. Otherwise, @code{#t} is +returned.@refill +@end deffn + +@deffn Procedure tmpnam +Returns a pathname for a file which will likely not be used by any other +process. Successive calls to @code{(tmpnam)} will return different +pathnames.@refill +@end deffn + +@deffn Procedure current-error-port +Returns the current port to which diagnostic and error output is +directed. +@end deffn + +@deffn Procedure force-output +@deffnx Procedure force-output port +Forces any pending output on @var{port} to be delivered to the output +device and returns an unspecified value. The @var{port} argument may be +omitted, in which case it defaults to the value returned by +@code{(current-output-port)}.@refill +@end deffn + +@deffn Procedure output-port-width +@deffnx Procedure output-port-width port + +Returns the width of @var{port}, which defaults to +@code{(current-output-port)} if absent. If the width cannot be +determined 79 is returned.@refill +@end deffn + +@deffn Procedure output-port-height +@deffnx Procedure output-port-height port + +Returns the height of @var{port}, which defaults to +@code{(current-output-port)} if absent. If the height cannot be +determined 24 is returned.@refill +@end deffn + +@node Legacy, System, Input/Output, Session Support +@section Legacy + +@defun identity x +@var{identity} returns its argument. + +Example: +@lisp +(identity 3) + @result{} 3 +(identity '(foo bar)) + @result{} (foo bar) +(map identity @var{lst}) + @equiv{} (copy-list @var{lst}) +@end lisp +@end defun + +These were present in Scheme until R4RS (@pxref{Notes, , Language +changes ,r4rs, Revised(4) Scheme}). + +@defvr Constant t +Derfined as @code{#t}. +@end defvr + +@defvr Constant nil +Defined as @code{#f}. +@end defvr + +@defun last-pair l +Returns the last pair in the list @var{l}. Example: +@lisp +(last-pair (cons 1 2)) + @result{} (1 . 2) +(last-pair '(1 2)) + @result{} (2) + @equiv{} (cons 2 '()) +@end lisp +@end defun + +@node System, , Legacy, Session Support +@section System + +These procedures are provided by all implementations. + +@deffn Procedure slib:load-source name +Loads a file of Scheme source code from @var{name} with the default +filename extension used in SLIB. For instance if the filename extension +used in SLIB is @file{.scm} then @code{(slib:load-source "foo")} will +load from file @file{foo.scm}. +@end deffn + +@deffn Procedure slib:load-compiled name +On implementations which support separtely loadable compiled modules, +loads a file of compiled code from @var{name} with the implementation's +filename extension for compiled code appended. +@end deffn + +@deffn Procedure slib:load name +Loads a file of Scheme source or compiled code from @var{name} with the +appropriate suffixes appended. If both source and compiled code are +present with the appropriate names then the implementation will load +just one. It is up to the implementation to choose which one will be +loaded. + +If an implementation does not support compiled code then +@code{slib:load} will be identical to @code{slib:load-source}. +@end deffn + +@deffn Procedure slib:eval obj +@code{eval} returns the value of @var{obj} evaluated in the current top +level environment.@refill +@end deffn + +@deffn Procedure slib:eval-load filename eval +@var{filename} should be a string. If filename names an existing file, +the Scheme source code expressions and definitions are read from the +file and @var{eval} called with them sequentially. The +@code{slib:eval-load} procedure does not affect the values returned by +@code{current-input-port} and @code{current-output-port}.@refill +@end deffn + +@deffn Procedure slib:error arg1 arg2 @dots{} +Outputs an error message containing the arguments, aborts evaluation of +the current form and responds in a system dependent way to the error. +Typical responses are to abort the program or to enter a read-eval-print +loop.@refill +@end deffn + +@deffn Procedure slib:exit n +@deffnx Procedure slib:exit +Exits from the Scheme session returning status @var{n} to the system. +If @var{n} is omitted or @code{#t}, a success status is returned to the +system (if possible). If @var{n} is @code{#f} a failure is returned to +the system (if possible). If @var{n} is an integer, then @var{n} is +returned to the system (if possible). If the Scheme session cannot exit +an unspecified value is returned from @code{slib:exit}. +@end deffn + + +@node Optional SLIB Packages, Procedure and Macro Index, Session Support, Top +@chapter Optional SLIB Packages + +Several Scheme packages have been written using SLIB. There are several +reasons why a package might not be included in the SLIB distribution: +@itemize @bullet +@item +Because it requires special hardware or software which is not universal. +@item +Because it is large and of limited interest to most Scheme users. +@item +Because it has copying terms different enough from the other SLIB +packages that its inclusion would cause confusion. +@item +Because it is an application program, rather than a library module. +@item +Because I have been too busy to integrate it. +@end itemize + +Once an optional package is installed (and an entry added to +@code{*catalog*}, the @code{require} mechanism allows it to be called up +and used as easily as any other SLIB package. Some optional packages +(for which @code{*catalog*} already has entries) available from SLIB +sites are: + +@table @asis +@item SLIB-PSD is a portable debugger for Scheme (requires emacs editor). +@lisp +ftp-swiss.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz +prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz +ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz +ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz +@end lisp + +With PSD, you can run a Scheme program in an Emacs buffer, set +breakpoints, single step evaluation and access and modify the program's +variables. It works by instrumenting the original source code, so it +should run with any R4RS compliant Scheme. It has been tested with SCM, +Elk 1.5, and the sci interpreter in the Scheme->C system, but should +work with other Schemes with a minimal amount of porting, if at +all. Includes documentation and user's manual. Written by Pertti +Kellom\"aki, pk@@cs.tut.fi. The Lisp Pointers article describing PSD +(Lisp Pointers VI(1):15-23, January-March 1993) is available as +@lisp +http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html +@end lisp +@item SLIB-SCHELOG is an embedding of Prolog in Scheme. +@lisp +ftp-swiss.ai.mit.edu:pub/scm/slib-schelog.tar.gz +prep.ai.mit.edu:pub/gnu/jacal/slib-schelog.tar.gz +ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-schelog.tar.gz +ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-schelog.tar.gz +@end lisp +@end table + +@node Procedure and Macro Index, Variable Index, Optional SLIB Packages, Top +@unnumbered Procedure and Macro Index + +This is an alphabetical list of all the procedures and macros in SLIB. + +@printindex fn + +@node Variable Index, , Procedure and Macro Index, Top +@unnumbered Variable Index + +This is an alphabetical list of all the global variables in SLIB. + +@printindex vr + +@contents +@bye diff --git a/sort.scm b/sort.scm new file mode 100644 index 0000000..ab9b938 --- /dev/null +++ b/sort.scm @@ -0,0 +1,154 @@ +;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort! +;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren) +;;; +;;; This code is in the public domain. + +;;; Updated: 11 June 1991 +;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991 +;;; Updated: 19 June 1995 + +;;; (sorted? sequence less?) +;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) +;;; such that for all 1 <= i <= m, +;;; (not (less? (list-ref list i) (list-ref list (- i 1)))). + +(define (sort:sorted? seq less?) + (cond + ((null? seq) + #t) + ((vector? seq) + (let ((n (vector-length seq))) + (if (<= n 1) + #t + (do ((i 1 (+ i 1))) + ((or (= i n) + (less? (vector-ref seq (- i 1)) + (vector-ref seq i))) + (= i n)) )) )) + (else + (let loop ((last (car seq)) (next (cdr seq))) + (or (null? next) + (and (not (less? (car next) last)) + (loop (car next) (cdr next)) )) )) )) + + +;;; (merge a b less?) +;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?) +;;; and returns a new list in which the elements of a and b have been stably +;;; interleaved so that (sorted? (merge a b less?) less?). +;;; Note: this does _not_ accept vectors. See below. + +(define (sort:merge a b less?) + (cond + ((null? a) b) + ((null? b) a) + (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b))) + ;; The loop handles the merging of non-empty lists. It has + ;; been written this way to save testing and car/cdring. + (if (less? y x) + (if (null? b) + (cons y (cons x a)) + (cons y (loop x a (car b) (cdr b)) )) + ;; x <= y + (if (null? a) + (cons x (cons y b)) + (cons x (loop (car a) (cdr a) y b)) )) )) )) + + +;;; (merge! a b less?) +;;; takes two sorted lists a and b and smashes their cdr fields to form a +;;; single sorted list including the elements of both. +;;; Note: this does _not_ accept vectors. + +(define (sort:merge! a b less?) + (define (loop r a b) + (if (less? (car b) (car a)) + (begin + (set-cdr! r b) + (if (null? (cdr b)) + (set-cdr! b a) + (loop b a (cdr b)) )) + ;; (car a) <= (car b) + (begin + (set-cdr! r a) + (if (null? (cdr a)) + (set-cdr! a b) + (loop a (cdr a) b)) )) ) + (cond + ((null? a) b) + ((null? b) a) + ((less? (car b) (car a)) + (if (null? (cdr b)) + (set-cdr! b a) + (loop b a (cdr b))) + b) + (else ; (car a) <= (car b) + (if (null? (cdr a)) + (set-cdr! a b) + (loop a (cdr a) b)) + a))) + + + +;;; (sort! sequence less?) +;;; sorts the list or vector sequence destructively. It uses a version +;;; of merge-sort invented, to the best of my knowledge, by David H. D. +;;; Warren, and first used in the DEC-10 Prolog system. R. A. O'Keefe +;;; adapted it to work destructively in Scheme. + +(define (sort:sort! seq less?) + (define (step n) + (cond + ((> n 2) + (let* ((j (quotient n 2)) + (a (step j)) + (k (- n j)) + (b (step k))) + (sort:merge! a b less?))) + ((= n 2) + (let ((x (car seq)) + (y (cadr seq)) + (p seq)) + (set! seq (cddr seq)) + (if (less? y x) (begin + (set-car! p y) + (set-car! (cdr p) x))) + (set-cdr! (cdr p) '()) + p)) + ((= n 1) + (let ((p seq)) + (set! seq (cdr seq)) + (set-cdr! p '()) + p)) + (else + '()) )) + (if (vector? seq) + (let ((n (vector-length seq)) + (vec seq)) + (set! seq (vector->list seq)) + (do ((p (step n) (cdr p)) + (i 0 (+ i 1))) + ((null? p) vec) + (vector-set! vec i (car p)) )) + ;; otherwise, assume it is a list + (step (length seq)) )) + +;;; (sort sequence less?) +;;; sorts a vector or list non-destructively. It does this by sorting a +;;; copy of the sequence. My understanding is that the Standard says +;;; that the result of append is always "newly allocated" except for +;;; sharing structure with "the last argument", so (append x '()) ought +;;; to be a standard way of copying a list x. + +(define (sort:sort seq less?) + (if (vector? seq) + (list->vector (sort:sort! (vector->list seq) less?)) + (sort:sort! (append seq '()) less?))) + +;;; eof + +(define sorted? sort:sorted?) +(define merge sort:merge) +(define merge! sort:merge!) +(define sort sort:sort) +(define sort! sort:sort!) diff --git a/soundex.scm b/soundex.scm new file mode 100644 index 0000000..eb3a542 --- /dev/null +++ b/soundex.scm @@ -0,0 +1,82 @@ +;"soundex.scm" Original SOUNDEX algorithm. +;From jjb@isye.gatech.edu Mon May 2 22:29:43 1994 +; +; This code is in the public domain. + +;Date: Mon, 2 May 94 13:45:39 -0500 + +; Taken from Knuth, Vol. 3 "Sorting and searching", pp 391--2 + +(require 'common-list-functions) + +(define SOUNDEX + (let* ((letters-to-omit + (list #\A #\E #\H #\I #\O #\U #\W #\Y)) + (codes + (list (list #\B #\1) + (list #\F #\1) + (list #\P #\1) + (list #\V #\1) + ; + (list #\C #\2) + (list #\G #\2) + (list #\J #\2) + (list #\K #\2) + (list #\Q #\2) + (list #\S #\2) + (list #\X #\2) + (list #\Z #\2) + ; + (list #\D #\3) + (list #\T #\3) + ; + (list #\L #\4) + ; + (list #\M #\5) + (list #\N #\5) + ; + (list #\R #\6))) + (xform + (lambda (c) + (let ((code (assq c codes))) + (if code + (cadr code) + c))))) + (lambda (name) + (let ((char-list + (map char-upcase + (remove-if (lambda (c) + (not (char-alphabetic? c))) + (string->list name))))) + (if (null? char-list) + name + (let* (; Replace letters except first with codes: + (n1 (cons (car char-list) (map xform char-list))) + ; If 2 or more letter with same code are adjacent + ; in the original name, omit all but the first: + (n2 (let loop ((chars n1)) + (cond ((null? (cdr chars)) + chars) + (else + (if (char=? (xform (car chars)) + (cadr chars)) + (loop (cdr chars)) + (cons (car chars) (loop (cdr chars)))))))) + ; Omit vowels and similar letters, except first: + (n3 (cons (car char-list) + (remove-if + (lambda (c) + (memq c letters-to-omit)) + (cdr n2))))) + ; + ; pad with 0's or drop rightmost digits until of form "annn": + (let loop ((rev-chars (reverse n3))) + (let ((len (length rev-chars))) + (cond ((= 4 len) + (list->string (reverse rev-chars))) + ((> 4 len) + (loop (cons #\0 rev-chars))) + ((< 4 len) + (loop (cdr rev-chars)))))))))))) + + diff --git a/stdio.scm b/stdio.scm new file mode 100644 index 0000000..bc4e914 --- /dev/null +++ b/stdio.scm @@ -0,0 +1,7 @@ + +(require 'scanf) +(require 'printf) + +(define stdin (current-input-port)) +(define stdout (current-output-port)) +(define stderr (current-error-port)) diff --git a/strcase.scm b/strcase.scm new file mode 100644 index 0000000..f223527 --- /dev/null +++ b/strcase.scm @@ -0,0 +1,45 @@ +;;; "strcase.scm" String casing functions. +; Written 1992 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de) +; +; This code is in the public domain. + +; Modified by Aubrey Jaffer Nov 1992. +; Authors of the original version were Ken Dickey and Aubrey Jaffer. + +;string-upcase, string-downcase, string-capitalize +; are obvious string conversion procedures and are non destructive. +;string-upcase!, string-downcase!, string-capitalize! +; are destructive versions. + +(define (string-upcase! str) + (do ((i (- (string-length str) 1) (- i 1))) + ((< i 0) str) + (string-set! str i (char-upcase (string-ref str i))))) + +(define (string-upcase str) + (string-upcase! (string-copy str))) + +(define (string-downcase! str) + (do ((i (- (string-length str) 1) (- i 1))) + ((< i 0) str) + (string-set! str i (char-downcase (string-ref str i))))) + +(define (string-downcase str) + (string-downcase! (string-copy str))) + +(define (string-capitalize! str) ; "hello" -> "Hello" + (let ((non-first-alpha #f) ; "hELLO" -> "Hello" + (str-len (string-length str))) ; "*hello" -> "*Hello" + (do ((i 0 (+ i 1))) ; "hello you" -> "Hello You" + ((= i str-len) str) + (let ((c (string-ref str i))) + (if (char-alphabetic? c) + (if non-first-alpha + (string-set! str i (char-downcase c)) + (begin + (set! non-first-alpha #t) + (string-set! str i (char-upcase c)))) + (set! non-first-alpha #f)))))) + +(define (string-capitalize str) + (string-capitalize! (string-copy str))) diff --git a/strport.scm b/strport.scm new file mode 100644 index 0000000..54d8d39 --- /dev/null +++ b/strport.scm @@ -0,0 +1,51 @@ +;;;;"strport.scm" Portable string ports for Scheme +;;;Copyright 1993 Dorai Sitaram and Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;N.B.: This implementation assumes you have tmpnam and +;delete-file defined in your .init file. tmpnam generates +;temp file names. delete-file may be defined to be a dummy +;procedure that does nothing. + +(define (call-with-output-string f) + (let ((tmpf (tmpnam))) + (call-with-output-file tmpf f) + (let ((s "") (buf (make-string 512))) + (call-with-input-file tmpf + (lambda (inp) + (let loop ((i 0)) + (let ((c (read-char inp))) + (cond ((eof-object? c) + (set! s (string-append s (substring buf 0 i)))) + ((>= i 512) + (set! s (string-append s buf)) + (loop 0)) + (else + (string-set! buf i c) + (loop (+ i 1)))))))) + (delete-file tmpf) + s))) + +(define (call-with-input-string s f) + (let ((tmpf (tmpnam))) + (call-with-output-file tmpf + (lambda (outp) + (display s outp))) + (let ((x (call-with-input-file tmpf f))) + (delete-file tmpf) + x))) diff --git a/strsrch.scm b/strsrch.scm new file mode 100644 index 0000000..a08510e --- /dev/null +++ b/strsrch.scm @@ -0,0 +1,95 @@ +;;; "MISCIO" Search for string from port. +; Written 1995, 1996 by Oleg Kiselyov (oleg@ponder.csci.unt.edu) +; Modified 1996 by A. Jaffer (jaffer@ai.mit.edu) +; +; This code is in the public domain. + +;;; Return the index of the first occurence of a-char in str, or #f +(define (string-index str a-char) + (let loop ((pos 0)) + (cond + ;; whole string has been searched, in vain + ((>= pos (string-length str)) #f) + ((char=? a-char (string-ref str pos)) pos) + (else (loop (+ 1 pos)))))) + +(define (substring? pattern str) + (let* ((pat-len (string-length pattern)) + (search-span (- (string-length str) pat-len)) + (c1 (if (zero? pat-len) #f (string-ref pattern 0))) + (c2 (if (<= pat-len 1) #f (string-ref pattern 1)))) + (cond + ((not c1) 0) ; empty pattern, matches upfront + ((not c2) (string-index str c1)) ; one-char pattern + (else ; matching pattern of > two chars + (let outer ((pos 0)) + (cond + ((> pos search-span) #f) ; nothing was found thru the whole str + ((not (char=? c1 (string-ref str pos))) + (outer (+ 1 pos))) ; keep looking for the right beginning + ((not (char=? c2 (string-ref str (+ 1 pos)))) + (outer (+ 1 pos))) ; could've done pos+2 if c1 == c2.... + (else ; two char matched: high probability + ; the rest will match too + (let inner ((i-pat 2) (i-str (+ 2 pos))) + (if (>= i-pat pat-len) pos ; the whole pattern matched + (if (char=? (string-ref pattern i-pat) + (string-ref str i-str)) + (inner (+ 1 i-pat) (+ 1 i-str)) + ;; mismatch after partial match + (outer (+ 1 pos)))))))))))) + +(define (find-string-from-port? str . max-no-char) + (set! max-no-char (if (null? max-no-char) #f (car max-no-char))) + (letrec + ((no-chars-read 0) + (my-peek-char ; Return a peeked char or #f + (lambda () (and (or (not max-no-char) (< no-chars-read max-no-char)) + (let ((c (peek-char ))) + (if (eof-object? c) #f c))))) + (next-char (lambda () (read-char ) + (set! no-chars-read (+ 1 no-chars-read)))) + (match-1st-char ; of the string str + (lambda () + (let ((c (my-peek-char))) + (if (not c) #f + (begin (next-char) + (if (char=? c (string-ref str 0)) + (match-other-chars 1) + (match-1st-char))))))) + ;; There has been a partial match, up to the point pos-to-match + ;; (for example, str[0] has been found in the stream) + ;; Now look to see if str[pos-to-match] for would be found, too + (match-other-chars + (lambda (pos-to-match) + (if (>= pos-to-match (string-length str)) + no-chars-read ; the entire string has matched + (let ((c (my-peek-char))) + (and c + (if (not (char=? c (string-ref str pos-to-match))) + (backtrack 1 pos-to-match) + (begin (next-char) + (match-other-chars (+ 1 pos-to-match))))))))) + + ;; There had been a partial match, but then a wrong char showed up. + ;; Before discarding previously read (and matched) characters, we check + ;; to see if there was some smaller partial match. Note, characters read + ;; so far (which matter) are those of str[0..matched-substr-len - 1] + ;; In other words, we will check to see if there is such i>0 that + ;; substr(str,0,j) = substr(str,i,matched-substr-len) + ;; where j=matched-substr-len - i + (backtrack + (lambda (i matched-substr-len) + (let ((j (- matched-substr-len i))) + (if (<= j 0) + ;; backed off completely to the begining of str + (match-1st-char) + (let loop ((k 0)) + (if (>= k j) + (match-other-chars j) ; there was indeed a shorter match + (if (char=? (string-ref str k) + (string-ref str (+ i k))) + (loop (+ 1 k)) + (backtrack (+ 1 i) matched-substr-len)))))))) + ) + (match-1st-char))) diff --git a/struct.scm b/struct.scm new file mode 100644 index 0000000..8c5c423 --- /dev/null +++ b/struct.scm @@ -0,0 +1,165 @@ +;;; "struct.scm": defmacros for RECORDS +;;; Copyright 1992 Jeff Alexander, Shinnder Lee, and Lewis Patterson + +;;; Defmacros which implement RECORDS from the book: +;;; "Essentials of Programming Languages" by Daniel P. Friedman, +;;; M. Wand and C.T. Haynes. + +;;; jaffer@ai.mit.edu, Feb 1993 ported to SLIB. + +;;; Date: Sun, 20 Aug 1995 19:20:35 -0500 +;;; From: Gary Leavens +;;; I thought you might want to know that, for using the file +;;; struct.scm with the EOPL book, one has to make 2 corrections. To +;;; correct it, there are two places where "-" has to be replaced by +;;; "->" as in the code below. + +(require 'common-list-functions) + +(defmacro define-record args + (check-define-record-syntax args + (lambda (name make-name name? field-accessors field-setters) + (letrec + ((make-fields + (lambda (field-accessors i) + (if (null? field-accessors) + '() + (cons + `(define ,(car field-accessors) + (lambda (obj) + (if (,name? obj) + (vector-ref obj ,i) + (slib:error ',(car field-accessors) + ": bad record" obj)))) + (make-fields (cdr field-accessors) (+ i 1)))))) + (make-setters + (lambda (field-accessors i) + (if (null? field-accessors) + '() + (cons + `(define ,(car field-accessors) + (lambda (obj val) + (if (,name? obj) + (vector-set! obj ,i val) + (slib:error ',(car field-accessors) + ": bad record" obj)))) + (make-setters (cdr field-accessors) (+ i 1))))))) + `(begin + ,@(make-fields field-accessors 1) + ,@(make-setters field-setters 1) + (define ,name? + (lambda (obj) + (and (vector? obj) + (= (vector-length obj) ,(+ 1 (length field-accessors))) + (eq? (vector-ref obj 0) ',name)))) + (define ,make-name + (lambda ,field-accessors + (vector ',name ,@field-accessors)))))))) + +(defmacro variant-case args + (check-variant-case-syntax args + (lambda (exp clauses) + (let ((var (gentemp))) + (let + ((make-clause + (lambda (clause) + (if (eq? (car clause) 'else) + `(#t ,@(cdr clause)) + `((,(car clause) ,var) + (let ,(map (lambda (field) + `(,(car field) (,(cdr field) ,var))) + (cadr clause)) + ,@(cddr clause))))))) + `(let ((,var ,exp)) + (cond ,@(map make-clause clauses)))))))) + +;;; syntax checkers + +;;; name make-name name? field-accessors + +(define check-define-record-syntax + (lambda (x k) + (cond + ((and (list? x) + (= (length x) 2) + (symbol? (car x)) + (list? (cadr x)) + (comlist:every symbol? (cadr x)) + (not (struct:duplicate-fields? (cadr x)))) + (let ((name (symbol->string (car x)))) + (let ((make-name (string->symbol + (string-append (symbol->string 'make-) name))) + (name? (string->symbol (string-append name "?"))) + (field-accessors + (map + (lambda (field) + (string->symbol + (string-append name "->" (symbol->string field)))) + (cadr x))) + (field-setters + (map + (lambda (field) + (string->symbol + (string-append + "set-" name "-" (symbol->string field) "!"))) + (cadr x)))) + (k (car x) make-name name? field-accessors field-setters)))) + (else (slib:error "define-record: invalid syntax" x))))) + +(define check-variant-case-syntax + (let + ((make-clause + (lambda (clause) + (if (eq? (car clause) 'else) + clause + (let ((name (symbol->string (car clause)))) + (let ((name? (string->symbol (string-append name "?"))) + (fields + (map + (lambda (field) + (cons field + (string->symbol + (string-append name "->" + (symbol->string field))))) + (cadr clause)))) + (cons name? (cons fields (cddr clause))))))))) + (lambda (args k) + (if (and (list? args) + (<= 2 (length args)) + (struct:clauses? (cdr args))) + (k (car args) (map make-clause (cdr args))) + (slib:error "variant-case: invalid syntax" args))))) + +(define struct:duplicate-fields? + (lambda (fields) + (cond + ((null? fields) #f) + ((memq (car fields) (cdr fields)) #t) + (else (struct:duplicate-fields? (cdr fields)))))) + +(define struct:clauses? + (let + ((clause? + (lambda (clause) + (and (list? clause) + (not (null? clause)) + (cond + ((eq? (car clause) 'else) + (not (null? (cdr clause)))) + (else (and (symbol? (car clause)) + (not (null? (cdr clause))) + (list? (cadr clause)) + (comlist:every symbol? (cadr clause)) + (not (struct:duplicate-fields? (cadr clause))) + (not (null? (cddr clause)))))))))) + (letrec + ((struct:duplicate-tags? + (lambda (tags) + (cond + ((null? tags) #f) + ((eq? (car tags) 'else) (not (null? (cdr tags)))) + ((memq (car tags) (cdr tags)) #t) + (else (struct:duplicate-tags? (cdr tags))))))) + (lambda (clauses) + (and (comlist:every clause? clauses) + (not (struct:duplicate-tags? (map car clauses)))))))) diff --git a/structst.scm b/structst.scm new file mode 100644 index 0000000..ea298e0 --- /dev/null +++ b/structst.scm @@ -0,0 +1,37 @@ +;"structst.scm" test "struct.scm" +;Copyright (C) 1993 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'struct) + +(define-record foo (a b c)) +(define-record goo (xx yy)) + +(define a-foo (make-foo 1 2 3)) +(define a-goo (make-goo 4 5)) + +(define (struct:test) + (define (t1 x) + (variant-case x + (foo (a b c) (list a b c)) + (goo (xx yy) (list xx yy)) + (else (list 7 8)))) + (write (append (t1 a-foo) (t1 a-goo) (t1 9))) + (newline)) + +(struct:test) diff --git a/structure.scm b/structure.scm new file mode 100644 index 0000000..0d379b9 --- /dev/null +++ b/structure.scm @@ -0,0 +1,80 @@ +;;; "structure.scm" syntax-case structure macros +;;; Copyright (C) 1992 R. Kent Dybvig +;;; +;;; Permission to copy this software, in whole or in part, to use this +;;; software for any lawful purpose, and to redistribute this software +;;; is granted subject to the restriction that all copies made of this +;;; software must include this copyright notice in full. This software +;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED, +;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY +;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE +;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY +;;; NATURE WHATSOEVER. + +;;; Written by Robert Hieb & Kent Dybvig + +;;; This file was munged by a simple minded sed script since it left +;;; its original authors' hands. See syncase.sh for the horrid details. + +;;; structure.ss +;;; Robert Hieb & Kent Dybvig +;;; 92/06/18 + +(define-syntax define-structure + (lambda (x) + (define construct-name + (lambda (template-identifier . args) + (implicit-identifier + template-identifier + (string->symbol + (apply string-append + (map (lambda (x) + (if (string? x) + x + (symbol->string (syntax-object->datum x)))) + args)))))) + (syntax-case x () + ((_ (name id1 ...)) + (syntax (define-structure (name id1 ...) ()))) + ((_ (name id1 ...) ((id2 init) ...)) + (with-syntax + ((constructor (construct-name (syntax name) "make-" (syntax name))) + (predicate (construct-name (syntax name) (syntax name) "?")) + ((access ...) + (map (lambda (x) (construct-name x (syntax name) "-" x)) + (syntax (id1 ... id2 ...)))) + ((assign ...) + (map (lambda (x) + (construct-name x "set-" (syntax name) "-" x "!")) + (syntax (id1 ... id2 ...)))) + (structure-length + (+ (length (syntax (id1 ... id2 ...))) 1)) + ((index ...) + (let f ((i 1) (ids (syntax (id1 ... id2 ...)))) + (if (null? ids) + '() + (cons i (f (+ i 1) (cdr ids))))))) + (syntax (begin + (define constructor + (lambda (id1 ...) + (let* ((id2 init) ...) + (vector 'name id1 ... id2 ...)))) + (define predicate + (lambda (x) + (and (vector? x) + (= (vector-length x) structure-length) + (eq? (vector-ref x 0) 'name)))) + (define access + (lambda (x) + (vector-ref x index))) + ... + ;; define macro accessors this way: + ;; (define-syntax access + ;; (syntax-case x () + ;; ((_ x) + ;; (syntax (vector-ref x index))))) + ;; ... + (define assign + (lambda (x update) + (vector-set! x index update))) + ...))))))) diff --git a/syncase.sh b/syncase.sh new file mode 100644 index 0000000..4ae4db4 --- /dev/null +++ b/syncase.sh @@ -0,0 +1,146 @@ +#! /bin/sh -e + +echo Cleaning up old version and unpacking original ... +rm -fr syntax-case +gzip --decompress --stdout syntax-case.tar.z | tar xf - + +cd syntax-case + +echo Removing some files ... +rm *.ps loadpp.ss hooks* + +# Remove enormous amount (about 200k) of white space in expand.pp +echo Slimming expand.pp ... +sed -e '/^ */s///' expand.pp > tt; mv tt expand.pp + +echo Patching ... +patch -s -b .ORIG << 'PATCH' +--- ./expand.pp.ORIG Wed Mar 24 19:54:52 1993 ++++ ./expand.pp Wed Mar 24 19:54:52 1993 +@@ -337,9 +337,10 @@ + '() + (lambda (e maps) (regen e))))) + (ellipsis? (lambda (x) +-(if (if (top-level-bound? 'dp) dp #f) +-(break) +-(void)) ++;; I dont know what this is supposed to do, and removing it seemed harmless. ++;; (if (if (top-level-bound? 'dp) dp #f) ++;; (break) ++;; (void)) + (if (identifier? x) + (free-id=? x '...) + #f))) +@@ -1674,7 +1675,7 @@ + (set! generate-temporaries + (lambda (ls) + (arg-check list? ls 'generate-temporaries) +-(map (lambda (x) (wrap (gensym) top-wrap)) ls))) ++(map (lambda (x) (wrap (new-symbol-hook "g") top-wrap)) ls))) + (set! free-identifier=? + (lambda (x y) + (arg-check id? x 'free-identifier=?) +--- ./expand.ss.ORIG Thu Jul 2 13:56:19 1992 ++++ ./expand.ss Wed Mar 24 19:54:53 1993 +@@ -564,7 +564,8 @@ + + (define ellipsis? + (lambda (x) +- (when (and (top-level-bound? 'dp) dp) (break)) ++ ;; I dont know what this is supposed to do, and removing it seemed harmless. ++ ;; (when (and (top-level-bound? 'dp) dp) (break)) + (and (identifier? x) + (free-id=? x (syntax (... ...)))))) + +@@ -887,7 +888,7 @@ + ;; gensym + (lambda (ls) + (arg-check list? ls 'generate-temporaries) +- (map (lambda (x) (wrap (gensym) top-wrap)) ls))) ++ (map (lambda (x) (wrap (new-symbol-hook "g") top-wrap)) ls))) + + (set! free-identifier=? + (lambda (x y) +--- ./macro-defs.ss.ORIG Thu Jul 2 12:28:49 1992 ++++ ./macro-defs.ss Wed Mar 24 19:55:31 1993 +@@ -161,26 +161,3 @@ + (syntax-case x () + ((- e) (gen (syntax e) 0)))))) + +-;;; simple delay and force; also defines make-promise +- +-(define-syntax delay +- (lambda (x) +- (syntax-case x () +- ((delay exp) +- (syntax (make-promise (lambda () exp))))))) +- +-(define make-promise +- (lambda (thunk) +- (let ([value (void)] [set? #f]) +- (lambda () +- (unless set? +- (let ([v (thunk)]) +- (unless set? +- (set! value v) +- (set! set? #t)))) +- value)))) +- +-(define force +- (lambda (promise) +- (promise))) +- +PATCH +test $# -gt 0 && exit 0 +rm *.ORIG +############################################################################### + +echo Renaming globals ... + +CR=' +' +SEDCMD='s/list\*/syncase:list*/g' +for x in \ + build- void andmap install-global-transformer eval-hook error-hook \ + new-symbol-hook put-global-definition-hook get-global-definition-hook \ + expand-install-hook; +do SEDCMD=$SEDCMD$CR"s/$x/syncase:$x/g"; done + +WARN=";;; This file was munged by a simple minded sed script since it left +;;; its original authors' hands. See syncase.doc for the horrid details. +" + +for f in *.pp *.ss; do + mv $f tt; (echo "$WARN"; sed -e "$SEDCMD" tt) >$f; rm tt; done + +echo Making the doc file ... +DOC=syncase.doc +cp ../$DOC . +for f in Notes ReadMe; do +echo " +******************************************************************************* +The file named $f in the original distribution: +" +cat $f +rm $f +done >>$DOC + +echo " +******************************************************************************* +The shell script that created these files out of the original distribution: +" >>$DOC +cat ../fixit >>$DOC + +echo Renaming files ... +mv compat.ss sca-comp.scm +mv output.ss scaoutp.scm +mv init.ss scaglob.scm +mv expand.pp scaexpp.scm +mv expand.ss sca-exp.scm +mv macro-defs.ss scamacr.scm +mv structure.ss structure.scm + +echo Adding new pieces ... +cp ../sca-init.scm scainit.scm + +echo Done. diff --git a/synchk.scm b/synchk.scm new file mode 100644 index 0000000..7e45a73 --- /dev/null +++ b/synchk.scm @@ -0,0 +1,104 @@ +;;; "synchk.scm" Syntax Checking -*-Scheme-*- +;;; Copyright (c) 1989-91 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of Electrical +;;; Engineering and Computer Science. Permission to copy this +;;; software, to redistribute it, and to use it for any purpose is +;;; granted, subject to the following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions +;;; that they make, so that these may be included in future releases; +;;; and (b) to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the +;;; usual standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation +;;; of this software will be error-free, and MIT is under no +;;; obligation to provide any services, by way of maintenance, update, +;;; or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the Massachusetts +;;; Institute of Technology nor of any adaptation thereof in any +;;; advertising, promotional, or sales literature without prior +;;; written consent from MIT in each case. + +;;;; Syntax Checking +;;; written by Alan Bawden +;;; modified by Chris Hanson + +(define (syntax-check pattern form) + (if (not (syntax-match? (cdr pattern) (cdr form))) + (syntax-error "ill-formed special form" form))) + +(define (ill-formed-syntax form) + (syntax-error "ill-formed special form" form)) + +(define (syntax-match? pattern object) + (let ((match-error + (lambda () + (impl-error "ill-formed pattern" pattern)))) + (cond ((symbol? pattern) + (case pattern + ((IDENTIFIER) (identifier? object)) + ((DATUM EXPRESSION FORM) #t) + ((R4RS-BVL) + (let loop ((seen '()) (object object)) + (or (null? object) + (if (identifier? object) + (not (memq object seen)) + (and (pair? object) + (identifier? (car object)) + (not (memq (car object) seen)) + (loop (cons (car object) seen) (cdr object))))))) + ((MIT-BVL) (lambda-list? object)) + (else (match-error)))) + ((pair? pattern) + (case (car pattern) + ((*) + (if (pair? (cdr pattern)) + (let ((head (cadr pattern)) + (tail (cddr pattern))) + (let loop ((object object)) + (or (and (pair? object) + (syntax-match? head (car object)) + (loop (cdr object))) + (syntax-match? tail object)))) + (match-error))) + ((+) + (if (pair? (cdr pattern)) + (let ((head (cadr pattern)) + (tail (cddr pattern))) + (and (pair? object) + (syntax-match? head (car object)) + (let loop ((object (cdr object))) + (or (and (pair? object) + (syntax-match? head (car object)) + (loop (cdr object))) + (syntax-match? tail object))))) + (match-error))) + ((?) + (if (pair? (cdr pattern)) + (or (and (pair? object) + (syntax-match? (cadr pattern) (car object)) + (syntax-match? (cddr pattern) (cdr object))) + (syntax-match? (cddr pattern) object)) + (match-error))) + ((QUOTE) + (if (and (pair? (cdr pattern)) + (null? (cddr pattern))) + (eqv? (cadr pattern) object) + (match-error))) + (else + (and (pair? object) + (syntax-match? (car pattern) (car object)) + (syntax-match? (cdr pattern) (cdr object)))))) + (else + (eqv? pattern object))))) diff --git a/synclo.scm b/synclo.scm new file mode 100644 index 0000000..3c61de3 --- /dev/null +++ b/synclo.scm @@ -0,0 +1,748 @@ +;;; "synclo.scm" Syntactic Closures -*-Scheme-*- +;;; Copyright (c) 1989-91 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of Electrical +;;; Engineering and Computer Science. Permission to copy this +;;; software, to redistribute it, and to use it for any purpose is +;;; granted, subject to the following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions +;;; that they make, so that these may be included in future releases; +;;; and (b) to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the +;;; usual standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation +;;; of this software will be error-free, and MIT is under no +;;; obligation to provide any services, by way of maintenance, update, +;;; or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the Massachusetts +;;; Institute of Technology nor of any adaptation thereof in any +;;; advertising, promotional, or sales literature without prior +;;; written consent from MIT in each case. + +;;;; Syntactic Closures +;;; written by Alan Bawden +;;; extensively modified by Chris Hanson + +;;; See "Syntactic Closures", by Alan Bawden and Jonathan Rees, in +;;; Proceedings of the 1988 ACM Conference on Lisp and Functional +;;; Programming, page 86. + +;;;; Classifier +;;; The classifier maps forms into items. In addition to locating +;;; definitions so that they can be properly processed, it also +;;; identifies keywords and variables, which allows a powerful form +;;; of syntactic binding to be implemented. + +(define (classify/form form environment definition-environment) + (cond ((identifier? form) + (syntactic-environment/lookup environment form)) + ((syntactic-closure? form) + (let ((form (syntactic-closure/form form)) + (environment + (filter-syntactic-environment + (syntactic-closure/free-names form) + environment + (syntactic-closure/environment form)))) + (classify/form form + environment + definition-environment))) + ((pair? form) + (let ((item + (classify/subexpression (car form) environment))) + (cond ((keyword-item? item) + ((keyword-item/classifier item) form + environment + definition-environment)) + ((list? (cdr form)) + (let ((items + (classify/subexpressions (cdr form) + environment))) + (make-expression-item + (lambda () + (output/combination + (compile-item/expression item) + (map compile-item/expression items))) + form))) + (else + (syntax-error "combination must be a proper list" + form))))) + (else + (make-expression-item ;don't quote literals evaluating to themselves + (if (or (boolean? form) (char? form) (number? form) (string? form)) + (lambda () (output/literal-unquoted form)) + (lambda () (output/literal-quoted form))) form)))) + +(define (classify/subform form environment definition-environment) + (classify/form form + environment + definition-environment)) + +(define (classify/subforms forms environment definition-environment) + (map (lambda (form) + (classify/subform form environment definition-environment)) + forms)) + +(define (classify/subexpression expression environment) + (classify/subform expression environment environment)) + +(define (classify/subexpressions expressions environment) + (classify/subforms expressions environment environment)) + +;;;; Compiler +;;; The compiler maps items into the output language. + +(define (compile-item/expression item) + (let ((illegal + (lambda (item name) + (let ((decompiled (decompile-item item))) (newline) + (slib:error (string-append name + " may not be used as an expression") + decompiled))))) + (cond ((variable-item? item) + (output/variable (variable-item/name item))) + ((expression-item? item) + ((expression-item/compiler item))) + ((body-item? item) + (let ((items (flatten-body-items (body-item/components item)))) + (if (null? items) + (illegal item "empty sequence") + (output/sequence (map compile-item/expression items))))) + ((definition-item? item) + (let ((binding ;allows later scheme errors, but allows top-level + (bind-definition-item! ;(if (not (defined? x)) define it) + scheme-syntactic-environment item))) ;as in Init.scm + (output/top-level-definition + (car binding) + (compile-item/expression (cdr binding))))) + ((keyword-item? item) + (illegal item "keyword")) + (else + (impl-error "unknown item" item))))) + +(define (compile/subexpression expression environment) + (compile-item/expression + (classify/subexpression expression environment))) + +(define (compile/top-level forms environment) + ;; Top-level syntactic definitions affect all forms that appear + ;; after them. + (output/top-level-sequence + (let forms-loop ((forms forms)) + (if (null? forms) + '() + (let items-loop + ((items + (item->list + (classify/subform (car forms) + environment + environment)))) + (cond ((null? items) + (forms-loop (cdr forms))) + ((definition-item? (car items)) + (let ((binding + (bind-definition-item! environment (car items)))) + (if binding + (cons (output/top-level-definition + (car binding) + (compile-item/expression (cdr binding))) + (items-loop (cdr items))) + (items-loop (cdr items))))) + (else + (cons (compile-item/expression (car items)) + (items-loop (cdr items)))))))))) + +;;;; De-Compiler +;;; The de-compiler maps partly-compiled things back to the input language, +;;; as far as possible. Used to display more meaningful macro error messages. + +(define (decompile-item item) + (display " ") + (cond ((variable-item? item) (variable-item/name item)) + ((expression-item? item) + (decompile-item (expression-item/annotation item))) + ((body-item? item) + (let ((items (flatten-body-items (body-item/components item)))) + (display "sequence") + (if (null? items) + "empty sequence" + "non-empty sequence"))) + ((definition-item? item) "definition") + ((keyword-item? item) + (decompile-item (keyword-item/name item)));in case expression + ((syntactic-closure? item); (display "syntactic-closure;") + (decompile-item (syntactic-closure/form item))) + ((list? item) (display "(") + (map decompile-item item) (display ")") "see list above") + ((string? item) item);explicit name-string for keyword-item + ((symbol? item) (display item) item) ;symbol for syntactic-closures + ((boolean? item) (display item) item) ;symbol for syntactic-closures + (else (write item) (impl-error "unknown item" item)))) + +;;;; Syntactic Closures + +(define syntactic-closure-type + (make-record-type "syntactic-closure" '(ENVIRONMENT FREE-NAMES FORM))) + +(define make-syntactic-closure + (record-constructor syntactic-closure-type '(ENVIRONMENT FREE-NAMES FORM))) + +(define syntactic-closure? + (record-predicate syntactic-closure-type)) + +(define syntactic-closure/environment + (record-accessor syntactic-closure-type 'ENVIRONMENT)) + +(define syntactic-closure/free-names + (record-accessor syntactic-closure-type 'FREE-NAMES)) + +(define syntactic-closure/form + (record-accessor syntactic-closure-type 'FORM)) + +(define (make-syntactic-closure-list environment free-names forms) + (map (lambda (form) (make-syntactic-closure environment free-names form)) + forms)) + +(define (strip-syntactic-closures object) + (cond ((syntactic-closure? object) + (strip-syntactic-closures (syntactic-closure/form object))) + ((pair? object) + (cons (strip-syntactic-closures (car object)) + (strip-syntactic-closures (cdr object)))) + ((vector? object) + (let ((length (vector-length object))) + (let ((result (make-vector length))) + (do ((i 0 (+ i 1))) + ((= i length)) + (vector-set! result i + (strip-syntactic-closures (vector-ref object i)))) + result))) + (else + object))) + +(define (identifier? object) + (or (symbol? object) + (synthetic-identifier? object))) + +(define (synthetic-identifier? object) + (and (syntactic-closure? object) + (identifier? (syntactic-closure/form object)))) + +(define (identifier->symbol identifier) + (cond ((symbol? identifier) + identifier) + ((synthetic-identifier? identifier) + (identifier->symbol (syntactic-closure/form identifier))) + (else + (impl-error "not an identifier" identifier)))) + +(define (identifier=? environment-1 identifier-1 environment-2 identifier-2) + (let ((item-1 (syntactic-environment/lookup environment-1 identifier-1)) + (item-2 (syntactic-environment/lookup environment-2 identifier-2))) + (or (eq? item-1 item-2) + ;; This is necessary because an identifier that is not + ;; explicitly bound by an environment is mapped to a variable + ;; item, and the variable items are not cached. Therefore + ;; two references to the same variable result in two + ;; different variable items. + (and (variable-item? item-1) + (variable-item? item-2) + (eq? (variable-item/name item-1) + (variable-item/name item-2)))))) + +;;;; Syntactic Environments + +(define syntactic-environment-type + (make-record-type + "syntactic-environment" + '(PARENT + LOOKUP-OPERATION + RENAME-OPERATION + DEFINE-OPERATION + BINDINGS-OPERATION))) + +(define make-syntactic-environment + (record-constructor syntactic-environment-type + '(PARENT + LOOKUP-OPERATION + RENAME-OPERATION + DEFINE-OPERATION + BINDINGS-OPERATION))) + +(define syntactic-environment? + (record-predicate syntactic-environment-type)) + +(define syntactic-environment/parent + (record-accessor syntactic-environment-type 'PARENT)) + +(define syntactic-environment/lookup-operation + (record-accessor syntactic-environment-type 'LOOKUP-OPERATION)) + +(define (syntactic-environment/assign! environment name item) + (let ((binding + ((syntactic-environment/lookup-operation environment) name))) + (if binding + (set-cdr! binding item) + (impl-error "can't assign unbound identifier" name)))) + +(define syntactic-environment/rename-operation + (record-accessor syntactic-environment-type 'RENAME-OPERATION)) + +(define (syntactic-environment/rename environment name) + ((syntactic-environment/rename-operation environment) name)) + +(define syntactic-environment/define! + (let ((accessor + (record-accessor syntactic-environment-type 'DEFINE-OPERATION))) + (lambda (environment name item) + ((accessor environment) name item)))) + +(define syntactic-environment/bindings + (let ((accessor + (record-accessor syntactic-environment-type 'BINDINGS-OPERATION))) + (lambda (environment) + ((accessor environment))))) + +(define (syntactic-environment/lookup environment name) + (let ((binding + ((syntactic-environment/lookup-operation environment) name))) + (cond (binding + (let ((item (cdr binding))) + (if (reserved-name-item? item) + (syntax-error "premature reference to reserved name" + name) + item))) + ((symbol? name) + (make-variable-item name)) + ((synthetic-identifier? name) + (syntactic-environment/lookup (syntactic-closure/environment name) + (syntactic-closure/form name))) + (else + (impl-error "not an identifier" name))))) + +(define root-syntactic-environment + (make-syntactic-environment + #f + (lambda (name) + name + #f) + (lambda (name) + name) + (lambda (name item) + (impl-error "can't bind name in root syntactic environment" name item)) + (lambda () + '()))) + +(define null-syntactic-environment + (make-syntactic-environment + #f + (lambda (name) + (impl-error "can't lookup name in null syntactic environment" name)) + (lambda (name) + (impl-error "can't rename name in null syntactic environment" name)) + (lambda (name item) + (impl-error "can't bind name in null syntactic environment" name item)) + (lambda () + '()))) + +(define (top-level-syntactic-environment parent) + (let ((bound '())) + (make-syntactic-environment + parent + (let ((parent-lookup (syntactic-environment/lookup-operation parent))) + (lambda (name) + (or (assq name bound) + (parent-lookup name)))) + (lambda (name) + name) + (lambda (name item) + (let ((binding (assq name bound))) + (if binding + (set-cdr! binding item) + (set! bound (cons (cons name item) bound))))) + (lambda () + (map (lambda (pair) (cons (car pair) (cdr pair))) bound))))) + +(define (internal-syntactic-environment parent) + (let ((bound '()) + (free '())) + (make-syntactic-environment + parent + (let ((parent-lookup (syntactic-environment/lookup-operation parent))) + (lambda (name) + (or (assq name bound) + (assq name free) + (let ((binding (parent-lookup name))) + (if binding (set! free (cons binding free))) + binding)))) + (make-name-generator) + (lambda (name item) + (cond ((assq name bound) + => + (lambda (association) + (if (and (reserved-name-item? (cdr association)) + (not (reserved-name-item? item))) + (set-cdr! association item) + (impl-error "can't redefine name; already bound" name)))) + ((assq name free) + (if (reserved-name-item? item) + (syntax-error "premature reference to reserved name" + name) + (impl-error "can't define name; already free" name))) + (else + (set! bound (cons (cons name item) bound))))) + (lambda () + (map (lambda (pair) (cons (car pair) (cdr pair))) bound))))) + +(define (filter-syntactic-environment names names-env else-env) + (if (or (null? names) + (eq? names-env else-env)) + else-env + (let ((make-operation + (lambda (get-operation) + (let ((names-operation (get-operation names-env)) + (else-operation (get-operation else-env))) + (lambda (name) + ((if (memq name names) names-operation else-operation) + name)))))) + (make-syntactic-environment + else-env + (make-operation syntactic-environment/lookup-operation) + (make-operation syntactic-environment/rename-operation) + (lambda (name item) + (impl-error "can't bind name in filtered syntactic environment" + name item)) + (lambda () + (map (lambda (name) + (cons name + (syntactic-environment/lookup names-env name))) + names)))))) + +;;;; Items + +;;; Reserved name items do not represent any form, but instead are +;;; used to reserve a particular name in a syntactic environment. If +;;; the classifier refers to a reserved name, a syntax error is +;;; signalled. This is used in the implementation of LETREC-SYNTAX +;;; to signal a meaningful error when one of the s refers to +;;; one of the names being bound. + +(define reserved-name-item-type + (make-record-type "reserved-name-item" '())) + +(define make-reserved-name-item + (record-constructor reserved-name-item-type)) ; '() + +(define reserved-name-item? + (record-predicate reserved-name-item-type)) + +;;; Keyword items represent macro keywords. + +(define keyword-item-type + (make-record-type "keyword-item" '(CLASSIFIER NAME))) +; (make-record-type "keyword-item" '(CLASSIFIER))) + +(define make-keyword-item +; (lambda (cl) (display "make-keyword-item:") (write cl) (newline) +; ((record-constructor keyword-item-type '(CLASSIFIER)) cl))) + (record-constructor keyword-item-type '(CLASSIFIER NAME))) +; (record-constructor keyword-item-type '(CLASSIFIER))) + +(define keyword-item? + (record-predicate keyword-item-type)) + +(define keyword-item/classifier + (record-accessor keyword-item-type 'CLASSIFIER)) + +(define keyword-item/name + (record-accessor keyword-item-type 'NAME)) + +;;; Variable items represent run-time variables. + +(define variable-item-type + (make-record-type "variable-item" '(NAME))) + +(define make-variable-item + (record-constructor variable-item-type '(NAME))) + +(define variable-item? + (record-predicate variable-item-type)) + +(define variable-item/name + (record-accessor variable-item-type 'NAME)) + +;;; Expression items represent any kind of expression other than a +;;; run-time variable or a sequence. The ANNOTATION field is used to +;;; make expression items that can appear in non-expression contexts +;;; (for example, this could be used in the implementation of SETF). + +(define expression-item-type + (make-record-type "expression-item" '(COMPILER ANNOTATION))) + +(define make-expression-item + (record-constructor expression-item-type '(COMPILER ANNOTATION))) + +(define expression-item? + (record-predicate expression-item-type)) + +(define expression-item/compiler + (record-accessor expression-item-type 'COMPILER)) + +(define expression-item/annotation + (record-accessor expression-item-type 'ANNOTATION)) + +;;; Body items represent sequences (e.g. BEGIN). + +(define body-item-type + (make-record-type "body-item" '(COMPONENTS))) + +(define make-body-item + (record-constructor body-item-type '(COMPONENTS))) + +(define body-item? + (record-predicate body-item-type)) + +(define body-item/components + (record-accessor body-item-type 'COMPONENTS)) + +;;; Definition items represent definitions, whether top-level or +;;; internal, keyword or variable. + +(define definition-item-type + (make-record-type "definition-item" '(BINDING-THEORY NAME VALUE))) + +(define make-definition-item + (record-constructor definition-item-type '(BINDING-THEORY NAME VALUE))) + +(define definition-item? + (record-predicate definition-item-type)) + +(define definition-item/binding-theory + (record-accessor definition-item-type 'BINDING-THEORY)) + +(define definition-item/name + (record-accessor definition-item-type 'NAME)) + +(define definition-item/value + (record-accessor definition-item-type 'VALUE)) + +(define (bind-definition-item! environment item) + ((definition-item/binding-theory item) + environment + (definition-item/name item) + (promise:force (definition-item/value item)))) + +(define (syntactic-binding-theory environment name item) + (if (or (keyword-item? item) + (variable-item? item)) + (begin + (syntactic-environment/define! environment name item) + #f) + (syntax-error "syntactic binding value must be a keyword or a variable" + item))) + +(define (variable-binding-theory environment name item) + ;; If ITEM isn't a valid expression, an error will be signalled by + ;; COMPILE-ITEM/EXPRESSION later. + (cons (bind-variable! environment name) item)) + +(define (overloaded-binding-theory environment name item) + (if (keyword-item? item) + (begin + (syntactic-environment/define! environment name item) + #f) + (cons (bind-variable! environment name) item))) + +;;;; Classifiers, Compilers, Expanders + +(define (sc-expander->classifier expander keyword-environment) + (lambda (form environment definition-environment) + (classify/form (expander form environment) + keyword-environment + definition-environment))) + +(define (er-expander->classifier expander keyword-environment) + (sc-expander->classifier (er->sc-expander expander) keyword-environment)) + +(define (er->sc-expander expander) + (lambda (form environment) + (capture-syntactic-environment + (lambda (keyword-environment) + (make-syntactic-closure + environment '() + (expander form + (let ((renames '())) + (lambda (identifier) + (let ((association (assq identifier renames))) + (if association + (cdr association) + (let ((rename + (make-syntactic-closure + keyword-environment + '() + identifier))) + (set! renames + (cons (cons identifier rename) + renames)) + rename))))) + (lambda (x y) + (identifier=? environment x + environment y)))))))) + +(define (classifier->keyword classifier) + (make-syntactic-closure + (let ((environment + (internal-syntactic-environment null-syntactic-environment))) + (syntactic-environment/define! environment + 'KEYWORD + (make-keyword-item classifier "c->k")) + environment) + '() + 'KEYWORD)) + +(define (compiler->keyword compiler) + (classifier->keyword (compiler->classifier compiler))) + +(define (classifier->form classifier) + `(,(classifier->keyword classifier))) + +(define (compiler->form compiler) + (classifier->form (compiler->classifier compiler))) + +(define (compiler->classifier compiler) + (lambda (form environment definition-environment) + definition-environment ;ignore + (make-expression-item + (lambda () (compiler form environment)) form))) + +;;;; Macrologies +;;; A macrology is a procedure that accepts a syntactic environment +;;; as an argument, producing a new syntactic environment that is an +;;; extension of the argument. + +(define (make-primitive-macrology generate-definitions) + (lambda (base-environment) + (let ((environment (top-level-syntactic-environment base-environment))) + (let ((define-classifier + (lambda (keyword classifier) + (syntactic-environment/define! + environment + keyword + (make-keyword-item classifier keyword))))) + (generate-definitions + define-classifier + (lambda (keyword compiler) + (define-classifier keyword (compiler->classifier compiler))))) + environment))) + +(define (make-expander-macrology object->classifier generate-definitions) + (lambda (base-environment) + (let ((environment (top-level-syntactic-environment base-environment))) + (generate-definitions + (lambda (keyword object) + (syntactic-environment/define! + environment + keyword + (make-keyword-item (object->classifier object environment) keyword))) + base-environment) + environment))) + +(define (make-sc-expander-macrology generate-definitions) + (make-expander-macrology sc-expander->classifier generate-definitions)) + +(define (make-er-expander-macrology generate-definitions) + (make-expander-macrology er-expander->classifier generate-definitions)) + +(define (compose-macrologies . macrologies) + (lambda (environment) + (do ((macrologies macrologies (cdr macrologies)) + (environment environment ((car macrologies) environment))) + ((null? macrologies) environment)))) + +;;;; Utilities + +(define (bind-variable! environment name) + (let ((rename (syntactic-environment/rename environment name))) + (syntactic-environment/define! environment + name + (make-variable-item rename)) + rename)) + +(define (reserve-names! names environment) + (let ((item (make-reserved-name-item))) + (for-each (lambda (name) + (syntactic-environment/define! environment name item)) + names))) + +(define (capture-syntactic-environment expander) + (classifier->form + (lambda (form environment definition-environment) + form ;ignore + (classify/form (expander environment) + environment + definition-environment)))) + +(define (unspecific-expression) + (compiler->form + (lambda (form environment) + form environment ;ignore + (output/unspecific)))) + +(define (unassigned-expression) + (compiler->form + (lambda (form environment) + form environment ;ignore + (output/unassigned)))) + +(define (syntax-quote expression) + `(,(compiler->keyword + (lambda (form environment) + environment ;ignore + (syntax-check '(KEYWORD DATUM) form) + (output/literal-quoted (cadr form)))) + ,expression)) + +(define (flatten-body-items items) + (append-map item->list items)) + +(define (item->list item) + (if (body-item? item) + (flatten-body-items (body-item/components item)) + (list item))) + +(define (output/let names values body) + (if (null? names) + body + (output/combination (output/lambda names body) values))) + +(define (output/letrec names values body) + (if (null? names) + body + (output/let + names + (map (lambda (name) name (output/unassigned)) names) + (output/sequence + (list (if (null? (cdr names)) + (output/assignment (car names) (car values)) + (let ((temps (map (make-name-generator) names))) + (output/let + temps + values + (output/sequence + (map output/assignment names temps))))) + body))))) + +(define (output/top-level-sequence expressions) + (if (null? expressions) + (output/unspecific) + (output/sequence expressions))) diff --git a/synrul.scm b/synrul.scm new file mode 100644 index 0000000..c23275f --- /dev/null +++ b/synrul.scm @@ -0,0 +1,327 @@ +;;; "synrul.scm" Rule-based Syntactic Expanders -*-Scheme-*- +;;; Copyright (c) 1989-91 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of Electrical +;;; Engineering and Computer Science. Permission to copy this +;;; software, to redistribute it, and to use it for any purpose is +;;; granted, subject to the following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions +;;; that they make, so that these may be included in future releases; +;;; and (b) to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the +;;; usual standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation +;;; of this software will be error-free, and MIT is under no +;;; obligation to provide any services, by way of maintenance, update, +;;; or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the Massachusetts +;;; Institute of Technology nor of any adaptation thereof in any +;;; advertising, promotional, or sales literature without prior +;;; written consent from MIT in each case. + +;;;; Rule-based Syntactic Expanders + +;;; See "Syntactic Extensions in the Programming Language Lisp", by +;;; Eugene Kohlbecker, Ph.D. dissertation, Indiana University, 1986. +;;; See also "Macros That Work", by William Clinger and Jonathan Rees +;;; (reference? POPL?). This implementation is derived from an +;;; implementation by Kent Dybvig, and includes some ideas from +;;; another implementation by Jonathan Rees. + +;;; The expansion of SYNTAX-RULES references the following keywords: +;;; ER-TRANSFORMER LAMBDA IF BEGIN SET! QUOTE +;;; and the following procedures: +;;; CAR CDR NULL? PAIR? EQUAL? MAP LIST CONS APPEND +;;; ILL-FORMED-SYNTAX +;;; it also uses the anonymous keyword SYNTAX-QUOTE. + +;;; For testing. +;;;(define (run-sr form) +;;; (expand/syntax-rules form (lambda (x) x) eq?)) + +(define (make-syntax-rules-macrology) + (make-er-expander-macrology + (lambda (define-classifier base-environment) + base-environment ;ignore + (define-classifier 'SYNTAX-RULES expand/syntax-rules)))) + +(define (expand/syntax-rules form rename compare) + (if (syntax-match? '((* IDENTIFIER) + ((IDENTIFIER . DATUM) EXPRESSION)) + (cdr form)) + (let ((keywords (cadr form)) + (clauses (cddr form))) + (if (let loop ((keywords keywords)) + (and (pair? keywords) + (or (memq (car keywords) (cdr keywords)) + (loop (cdr keywords))))) + (syntax-error "keywords list contains duplicates" keywords) + (let ((r-form (rename 'FORM)) + (r-rename (rename 'RENAME)) + (r-compare (rename 'COMPARE))) + `(,(rename 'ER-TRANSFORMER) + (,(rename 'LAMBDA) + (,r-form ,r-rename ,r-compare) + ,(let loop ((clauses clauses)) + (if (null? clauses) + `(,(rename 'ILL-FORMED-SYNTAX) ,r-form) + (let ((pattern (caar clauses))) + (let ((sids + (parse-pattern rename compare keywords + pattern r-form))) + `(,(rename 'IF) + ,(generate-match rename compare keywords + r-rename r-compare + pattern r-form) + ,(generate-output rename compare r-rename + sids (cadar clauses) + syntax-error) + ,(loop (cdr clauses)))))))))))) + (ill-formed-syntax form))) + +(define (parse-pattern rename compare keywords pattern expression) + (let loop + ((pattern pattern) + (expression expression) + (sids '()) + (control #f)) + (cond ((identifier? pattern) + (if (memq pattern keywords) + sids + (cons (make-sid pattern expression control) sids))) + ((and (or (zero-or-more? pattern rename compare) + (at-least-one? pattern rename compare)) + (null? (cddr pattern))) + (let ((variable ((make-name-generator) 'CONTROL))) + (loop (car pattern) + variable + sids + (make-sid variable expression control)))) + ((pair? pattern) + (loop (car pattern) + `(,(rename 'CAR) ,expression) + (loop (cdr pattern) + `(,(rename 'CDR) ,expression) + sids + control) + control)) + (else sids)))) + +(define (generate-match rename compare keywords r-rename r-compare + pattern expression) + (letrec + ((loop + (lambda (pattern expression) + (cond ((identifier? pattern) + (if (memq pattern keywords) + (let ((temp (rename 'TEMP))) + `((,(rename 'LAMBDA) + (,temp) + (,(rename 'IF) + (,(rename 'IDENTIFIER?) ,temp) + (,r-compare ,temp + (,r-rename ,(syntax-quote pattern))) + #f)) + ,expression)) + `#t)) + ((and (zero-or-more? pattern rename compare) + (null? (cddr pattern))) + (do-list (car pattern) expression)) + ((and (at-least-one? pattern rename compare) + (null? (cddr pattern))) + `(,(rename 'IF) (,(rename 'NULL?) ,expression) + #F + ,(do-list (car pattern) expression))) + ((pair? pattern) + (let ((generate-pair + (lambda (expression) + (conjunction + `(,(rename 'PAIR?) ,expression) + (conjunction + (loop (car pattern) + `(,(rename 'CAR) ,expression)) + (loop (cdr pattern) + `(,(rename 'CDR) ,expression))))))) + (if (identifier? expression) + (generate-pair expression) + (let ((temp (rename 'TEMP))) + `((,(rename 'LAMBDA) (,temp) ,(generate-pair temp)) + ,expression))))) + ((null? pattern) + `(,(rename 'NULL?) ,expression)) + (else + `(,(rename 'EQUAL?) ,expression + (,(rename 'QUOTE) ,pattern)))))) + (do-list + (lambda (pattern expression) + (let ((r-loop (rename 'LOOP)) + (r-l (rename 'L)) + (r-lambda (rename 'LAMBDA))) + `(((,r-lambda + (,r-loop) + (,(rename 'BEGIN) + (,(rename 'SET!) + ,r-loop + (,r-lambda + (,r-l) + (,(rename 'IF) + (,(rename 'NULL?) ,r-l) + #T + ,(conjunction + `(,(rename 'PAIR?) ,r-l) + (conjunction (loop pattern `(,(rename 'CAR) ,r-l)) + `(,r-loop (,(rename 'CDR) ,r-l))))))) + ,r-loop)) + #F) + ,expression)))) + (conjunction + (lambda (predicate consequent) + (cond ((eq? predicate #T) consequent) + ((eq? consequent #T) predicate) + (else `(,(rename 'IF) ,predicate ,consequent #F)))))) + (loop pattern expression))) + +(define (generate-output rename compare r-rename sids template syntax-error) + (let loop ((template template) (ellipses '())) + (cond ((identifier? template) + (let ((sid + (let loop ((sids sids)) + (and (not (null? sids)) + (if (eq? (sid-name (car sids)) template) + (car sids) + (loop (cdr sids))))))) + (if sid + (begin + (add-control! sid ellipses syntax-error) + (sid-expression sid)) + `(,r-rename ,(syntax-quote template))))) + ((or (zero-or-more? template rename compare) + (at-least-one? template rename compare)) + (optimized-append rename compare + (let ((ellipsis (make-ellipsis '()))) + (generate-ellipsis rename + ellipsis + (loop (car template) + (cons ellipsis + ellipses)))) + (loop (cddr template) ellipses))) + ((pair? template) + (optimized-cons rename compare + (loop (car template) ellipses) + (loop (cdr template) ellipses))) + (else + `(,(rename 'QUOTE) ,template))))) + +(define (add-control! sid ellipses syntax-error) + (let loop ((sid sid) (ellipses ellipses)) + (let ((control (sid-control sid))) + (cond (control + (if (null? ellipses) + (syntax-error "missing ellipsis in expansion" #f) + (let ((sids (ellipsis-sids (car ellipses)))) + (cond ((not (memq control sids)) + (set-ellipsis-sids! (car ellipses) + (cons control sids))) + ((not (eq? control (car sids))) + (syntax-error "illegal control/ellipsis combination" + control sids))))) + (loop control (cdr ellipses))) + ((not (null? ellipses)) + (syntax-error "extra ellipsis in expansion" #f)))))) + +(define (generate-ellipsis rename ellipsis body) + (let ((sids (ellipsis-sids ellipsis))) + (let ((name (sid-name (car sids))) + (expression (sid-expression (car sids)))) + (cond ((and (null? (cdr sids)) + (eq? body name)) + expression) + ((and (null? (cdr sids)) + (pair? body) + (pair? (cdr body)) + (eq? (cadr body) name) + (null? (cddr body))) + `(,(rename 'MAP) ,(car body) ,expression)) + (else + `(,(rename 'MAP) (,(rename 'LAMBDA) ,(map sid-name sids) ,body) + ,@(map sid-expression sids))))))) + +(define (zero-or-more? pattern rename compare) + (and (pair? pattern) + (pair? (cdr pattern)) + (identifier? (cadr pattern)) + (compare (cadr pattern) (rename '...)))) + +(define (at-least-one? pattern rename compare) +;;; (and (pair? pattern) +;;; (pair? (cdr pattern)) +;;; (identifier? (cadr pattern)) +;;; (compare (cadr pattern) (rename '+))) + pattern rename compare ;ignore + #f) + +(define (optimized-cons rename compare a d) + (cond ((and (pair? d) + (compare (car d) (rename 'QUOTE)) + (pair? (cdr d)) + (null? (cadr d)) + (null? (cddr d))) + `(,(rename 'LIST) ,a)) + ((and (pair? d) + (compare (car d) (rename 'LIST)) + (list? (cdr d))) + `(,(car d) ,a ,@(cdr d))) + (else + `(,(rename 'CONS) ,a ,d)))) + +(define (optimized-append rename compare x y) + (if (and (pair? y) + (compare (car y) (rename 'QUOTE)) + (pair? (cdr y)) + (null? (cadr y)) + (null? (cddr y))) + x + `(,(rename 'APPEND) ,x ,y))) + +(define sid-type + (make-record-type "sid" '(NAME EXPRESSION CONTROL OUTPUT-EXPRESSION))) + +(define make-sid + (record-constructor sid-type '(NAME EXPRESSION CONTROL))) + +(define sid-name + (record-accessor sid-type 'NAME)) + +(define sid-expression + (record-accessor sid-type 'EXPRESSION)) + +(define sid-control + (record-accessor sid-type 'CONTROL)) + +(define sid-output-expression + (record-accessor sid-type 'OUTPUT-EXPRESSION)) + +(define set-sid-output-expression! + (record-modifier sid-type 'OUTPUT-EXPRESSION)) + +(define ellipsis-type + (make-record-type "ellipsis" '(SIDS))) + +(define make-ellipsis + (record-constructor ellipsis-type '(SIDS))) + +(define ellipsis-sids + (record-accessor ellipsis-type 'SIDS)) + +(define set-ellipsis-sids! + (record-modifier ellipsis-type 'SIDS)) diff --git a/t3.init b/t3.init new file mode 100644 index 0000000..b9a0191 --- /dev/null +++ b/t3.init @@ -0,0 +1,425 @@ +;"t3.init" Initialization file for SLIB for T3.1. -*-scheme-*- +;Copyright (C) 1991, 1992 David Carlton & Stephen Bevan +;Copyright 1993 F. Javier Thayer. +;Copyright (C) 1991, 1992, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; File has T syntax, and should be compiled in standard-env. +;;; Compiled file has .so suffix. +;;; File (or compiled version) should be loaded into scheme-env. + +;;; This is provided with ABSOLUTELY NO GUARANTEE. +(herald t3) + +(define (software-type) 'UNIX) + +(define (scheme-implementation-type) 'T) + +(define (scheme-implementation-version) "3.1") + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. It is settable. + +(define implementation-vicinity + (make-simple-switch 'implementation-vicinity + (lambda (x) (or (string? x) (false? x))) + '#f)) +(set (implementation-vicinity) "/usr/local/lib/tsystem/") + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. It is settable. + +(define library-vicinity + (make-simple-switch 'library-vicinity + (lambda (x) (or (string? x) (false? x))) + '#f)) +(set (library-vicinity) "/usr/local/lib/slib/") +;;Obviously put your value here. + +;;; *FEATURES* should be set to a list of symbols describing features +;;; of this implementation. See Template.scm for the list of feature +;;; names. + +(define *features* + '( + source ;can load scheme source files + ;(slib:load-source "filename") + compiled ;can load compiled files + ;(slib:load-compiled "filename") + rev3-report + rev4-optional-procedures + rev3-procedures + rev2-procedures + multiarg/and- + multiarg-apply + rationalize + object-hash + delay + i/o-redirection + char-ready? + with-file + transcript + full-continuation + pretty-print + format + trace ;has macros: TRACE and UNTRACE + program-arguments + )) + +(define substring + (let ((primitive-substring (*value standard-env 'substring))) + (lambda (string start end) + (primitive-substring string start (max 0 (- end 1)))))) + +; Modify substring as T's substring takes (start,count) instead of +; (start,end) + +(set (syntax-table-entry (env-syntax-table scheme-env) 'require) '#f) + +; Turn off the macro REQUIRE so that it can be rebound as a function +; later. + +; extend <, >, <= and >= so that they take more than two arguments. + +(define < + (let ((primitive< (*value standard-env '<))) + (labels ((v (lambda (a b . rest) + (if (null? rest) + (primitive< a b) + (and (primitive< a b) + (apply v b (car rest) (cdr rest))))))) + v))) + +(define > + (let ((primitive> (*value standard-env '>))) + (labels ((v (lambda (a b . rest) + (if (null? rest) + (primitive> a b) + (and (primitive> a b) + (apply v b (car rest) (cdr rest))))))) + v))) + +(define <= + (let ((primitive<= (*value standard-env '<=))) + (labels ((v (lambda (a b . rest) + (if (null? rest) + (primitive<= a b) + (and (primitive<= a b) + (apply v b (car rest) (cdr rest))))))) + v))) + +(define >= + (let ((primitive>= (*value standard-env '>=))) + (labels ((v (lambda (a b . rest) + (if (null? rest) + (primitive>= a b) + (and (primitive>= a b) + (apply v b (car rest) (cdr rest))))))) + v))) + +(define = + (let ((primitive= (*value standard-env '=))) + (labels ((v (lambda (a b . rest) + (if (null? rest) + (primitive= a b) + (and (primitive= a b) + (apply v b (car rest) (cdr rest))))))) + v))) + +(define gcd + (let ((prim (*value standard-env 'gcd))) + (labels ((v (lambda x + (cond ((null? x) 0) + ((= (length x) 1) (car x)) + ('#t (prim (car x) (apply v (cdr x)))))))) + v))) + +(define list? (*value standard-env 'proper-list?)) + +(define program-arguments command-line) + +;;; (OUTPUT-PORT-WIDTH ) +(define output-port-width + (lambda x + (if (null? x) (line-length (standard-input)) + (line-length (car x))))) + +;;; (OUTPUT-PORT-HEIGHT ) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +(define current-error-port + (let ((port (current-output-port))) + (lambda () port))) + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam + (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (let ((tmp (string-append "slib_" (number->string cntr)))) + (if (file-exists? tmp) (tmpnam) tmp))))) + +(define delete-file file-delete) + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +(define char-code-limit 256) + +;;; MOST-POSITIVE-FIXNUM is used in modular.scm +;;; T already has it. + +;;; Return argument +(define (identity x) x) + +;;; If your implementation provides eval, SLIB:EVAL is single argument +;;; eval using the top-level (user) environment. +(define (slib:eval form) (eval form scheme-env)) + +;;; If your implementation provides R4RS macros: +;(define macro:eval slib:eval) +;(define macro:load load) + +(define *defmacros* + (list (cons 'defmacro + (lambda (name parms . body) + `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) + *defmacros*)))))) +(define (defmacro? m) (and (assq m *defmacros*) #t)) + +(define (macroexpand-1 e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) (set! a (assq a *defmacros*)) + (if a (apply (cdr a) (cdr e)) e)) + (else e))) + e)) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) + (set! a (assq a *defmacros*)) + (if a (macroexpand (apply (cdr a) (cdr e))) e)) + (else e))) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +(define base:eval slib:eval) +(define (defmacro:eval x) (base:eval (defmacro:expand* x))) +(define (defmacro:expand* x) + (require 'defmacroexpand) (apply defmacro:expand* x '())) + +(define (defmacro:load ) + (slib:eval-load defmacro:eval)) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;;; define an error procedure for the library +(define slib:error error) + +;;; define these as appropriate for your system. +(define slib:tab #\tab) +(define slib:form-feed #\form) + +;;; Define these if your implementation's syntax can support it and if +;;; they are not already defined. + +;(define (1+ n) (+ n 1)) +(define (1- n) (+ n -1)) +;(define (-1+ n) (+ n -1)) + +(define program-vicinity + (make-simple-switch 'program-vicinity + (lambda (x) (or (string? x) (false? x))) + '#f)) + +(define in-vicinity string-append) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:exit (lambda args (exit)) + +(define (string . args) (apply string-append (map char->string args))) + +(define make-string + (let ((t:make-string (*value standard-env 'make-string))) + (lambda (a . b) + (let ((str (t:make-string a))) + (if b (map-string! (lambda (x) (ignore x) (car b)) str) str))))) + +(define (string>? a b) + (labels ((aux + (lambda (n a b) + ;;start off with n<=(string-length b) and n<=(string-length a) + ;;a,b coincide for chars ? b a)) +(define (string<=? a b) (not (string>? a b))) +(define (string>=? a b) (not (string? a b) + (string>? (string-upcase a) (string-upcase b))) + +(define (string-ci<=? a b) + (string<=? (string-upcase a) (string-upcase b))) + +(define (string-ci>=? a b) + (string>=? (string-upcase a) (string-upcase b))) + +;;; FORCE-OUTPUT flushes any pending output on optional arg output port +;;; use this definition if your system doesn't have such a procedure. +;;; T already has it, but requires 1 argument. + +(define force-output + (let ((t:force-output (*value standard-env 'force-output))) + (lambda x + (if x + (t:force-output (car x)) + (t:force-output (current-output-port)))))) + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-*PUT-FILE. +(define (call-with-output-string proc) + (with-output-to-string var (proc var))) + +(define (call-with-input-string string proc) + (with-input-from-string (variable string) (proc variable))) + +(define (string->number s . x) + (let ((base (if x (car x) 10)) + (s (string-upcase s))) + (or (mem? = base '(8 10 16)) + (error (format (current-error-port) "Bad radix ~A" base))) + (if (= (string-length s) 0) '() + (let ((char->number + (lambda (ch) + (cdr (ass char=? ch + '((#\0 . 0) + (#\1 . 1) (#\2 . 2) (#\3 . 3) (#\4 . 4) + (#\5 . 5) (#\6 . 6) (#\7 . 7) (#\8 . 8) + (#\9 . 9) (#\A . 10) (#\B . 11) (#\C . 12) + (#\D . 13) (#\E . 14) (#\F . 15))))))) + (catch not-num + (iterate loop ((pos (- (string-length s) 1)) + (power 1) (accum 0)) + (if (< pos 0) accum + (let ((num (char->number (string-ref s pos)))) + (or num (not-num '())) + (or (< num base) (not-num '())) + (loop (- pos 1) + (* power base) + (+ accum (* num power))))))))))) + +(define (number->string n . x) + (let ((rad (if (car x) (car x) 10))) + (format nil + (case rad + ((8) "~O") + ((10) "~D") + ((16) "~X") + (else (error (format (current-error-port) + "Bad radix ~A" (car x))))) + n))) + +(define (inexact? f) + (float? f)) + +(define (exact? f) + (not (inexact? f))) + +(define exact->inexact ->float) + +(define peek-char + (let ((t:peek-char (*value standard-env 'peek-char))) + (lambda p + (let ((port (if p (car p) (current-input-port)))) + (t:peek-char port))))) + +;;;(set ((*value scheme-env 'standard-early-binding-env) 'load) '#f) +;;;(set ((*value scheme-env 'standard-early-binding-env) 'substring) '#f) +(set ((*value scheme-env 'standard-early-binding-env) 'less?) '#f) +(set ((*value scheme-env 'standard-early-binding-env) 'greater?) '#f) +(set ((*value scheme-env 'standard-early-binding-env) 'not-less?) '#f) +(set ((*value scheme-env 'standard-early-binding-env) 'not-greater?) '#f) +(set ((*value scheme-env 'standard-early-binding-env) 'number-equal?) '#f) +(set ((*value scheme-internal-env 'standard-early-binding-env) 'list?) '#f) + +(set ((*value t-implementation-env 'SOURCE-FILE-EXTENSION)) 'scm) + +;;; Here for backward compatability +(define (scheme-file-suffix) "") + +(define load + (let ((t:load (*value standard-env 'load))) + (lambda (filespec . x) + (apply t:load (->filename filespec) x)))) + +;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;; suffix all the module files in SLIB have. See feature 'SOURCE. + +(define slib:load-source load) + +;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;; by compiling "foo.scm" if this implementation can compile files. +;;; See feature 'COMPILED. + +(define slib:load-compiled load) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) + +(slib:load (in-vicinity (library-vicinity) "require") scheme-env) + +;;;(define scheme-read-table +;;; (make-read-table standard-read-table 'modified-read-table)) +;;; +;;;(set (read-table-entry scheme-read-table '#\#) +;;; (lambda (p ch rtable) +;;; (ignore ch) (ignore rtable) +;;; ((*value scheme-env 'string->number) +;;; (symbol->string (read-refusing-eof p)) 16))) +;;; +;;;(set (port-read-table (standard-input)) scheme-read-table) + +; eof diff --git a/tek40.scm b/tek40.scm new file mode 100644 index 0000000..f45a1fa --- /dev/null +++ b/tek40.scm @@ -0,0 +1,92 @@ +;"tek40.scm", Tektronix 4000 series graphics support in Scheme. +;Copyright (C) 1992, 1994 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;THIS FILE NEEDS MORE WORK. + +;The Tektronix 4000 series graphics protocol gives the user a 1024 by +;1024 square drawing area. The origin is in the lower left corner of +;the screen. Increasing y is up and increasing x is to the right. + +;The graphics control codes are sent over the current-output-port and +;can be mixed with regular text and ANSI or other terminal control +;sequences. + +; (tek40:init) procedure + +(define (tek40:init) 'noop) + +(define esc-string (string (integer->char #o33))) + +(define tek40:graphics-str + (string-append + (string slib:form-feed) + esc-string (string (integer->char #o14)) + ;; clear the screen + )) + +(define (tek40:graphics) (display tek40:graphics-str) (force-output)) + +(define (tek40:text) + (tek40:move 0 12) + (write-char (integer->char #o37))) + +(define (tek40:linetype linetype) + (cond ((or (negative? linetype) (> linetype 15)) + (slib:error "bad linetype" linetype)) + (else + (display esc-string) + (write-char (integer->char (+ (char->integer #\`) linetype)))))) + +(define (tek40:move x y) + (write-char (integer->char #o35)) + (tek40:draw x y)) + +(define (tek40:draw x y) + (display (string + (integer->char (+ #x20 (quotient y 32))) + (integer->char (+ #x60 (remainder y 32))) + (integer->char (+ #x20 (quotient x 32))) + (integer->char (+ #x40 (remainder x 32)))))) + +(define (tek40:put-text x y str) + (tek40:move x (+ y -11)) + (write-char (integer->char #o37)) + (display str)) + +(define (tek40:reset) (display tek40:graphics-str) (force-output)) + +(define (tek40:test) + (tek40:init) +; (tek40:reset) + (tek40:graphics) + (tek40:linetype 0) + (tek40:move 100 100) + (tek40:draw 200 100) + (tek40:draw 200 200) + (tek40:draw 100 200) + (tek40:draw 100 100) + (do ((i 0 (+ 1 i))) + ((> i 15)) + (tek40:linetype i) + (tek40:move (+ (* 50 i) 100) 100) + (tek40:put-text (+ (* 50 i) 100) 100 (number->string i)) + (tek40:move (+ (* 50 i) 100) 100) + (tek40:draw (+ (* 50 i) 200) 200)) + (tek40:linetype 0) + (tek40:text)) diff --git a/tek41.scm b/tek41.scm new file mode 100644 index 0000000..988f8ea --- /dev/null +++ b/tek41.scm @@ -0,0 +1,147 @@ +;"tek41.scm", Tektronix 4100 series graphics support in Scheme. +;Copyright (C) 1992, 1994 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;THIS FILE NEEDS MORE WORK. Let me know if you test or fix it. + +;The graphics control codes are sent over the current-output-port and +;can be mixed with regular text and ANSI or other terminal control +;sequences. + +(define esc-string (string (integer->char #o33))) + +(define tek41:init + (string-append + esc-string "%!0" + ;;1. set tek mode + esc-string "MN0" + ;;2. set character path to 0 (characters placed equal to rotation) + esc-string "MCB7C;" + ;;3. set character size to 59 height + esc-string "MQ1" + ;;4. set character precision to string + esc-string "MT1" + ;;5. set character text index to 1 + esc-string "MG1" + ;;6. set character write mode to overstrike + esc-string "RK!" + ;;7. clear the view + esc-string "SK!" + ;;8. clear the segments + esc-string "LZ" + ;;9. clear the dialog buffer + esc-string "%!1" + ;;10. set ansi mode + )) + +(define (tek41:init) (display tek41:init-str) (force-output)) + +(define (tek41:reset) + (string-append + esc-string "%!0" + ;;1. set tek mode + esc-string "LZ" + ;;2. clear the dialog buffer + esc-string "%!1" + ;;3. set ansi mode + )) + +(define (tek41:reset) (display tek41:reset-str) (force-output)) + +(define tek41:graphics-str + (string-append + esc-string "%!0" + ;;1. set tek mode + esc-string (string (integer->char #o14)) + ;;2. clear the screen + esc-string "LV0" + ;;3. set dialog area invisible + )) + +(define (tek41:graphics) (display tek41:graphics-str) (force-output)) + +(define tek41:text-str + (string-append + esc-string "LV1" + ;;1. set dialog area visible + esc-string "%!1" + ;;2. set ansi mode + )) + +(define (tek41:text) (display tek41:text-str) (force-output)) + +(define tek41:move-str + (string-append esc-string "LF")) + +(define (tek41:move x y) + (display tek41:move-str) + (tek41:encode-x-y x y) + (force-output)) + +(define tek41:draw-str + (string-append esc-string "LG")) + +(define (tek41:draw x y) + (display tek41:draw-str) + (tek41:encode-x-y x y) + (force-output)) + +(define tek41:set-marker-str (string-append esc-string "MM")) +(define tek41:draw-marker-str (string-append esc-string "LH")) + +(define (tek41:point x y number) + (display tek41:set-marker-str) + (tek41:encode-int (remainder (max number 0) 11)) + (display tek41:draw-marker-str) + (tek41:encode-x-y x y) + (force-output)) + +(define (tek41:encode-x-y x y) + (let ((hix (+ (quotient x 128) 32)) + (lox (+ (modulo (quotient x 4) 32) 64)) + (hiy (+ (quotient y 128) 32)) + (loy (+ (modulo (quotient y 4) 32) 96)) + (eb (+ (* (modulo y 4) 4) (modulo x 4) 96))) + (if (positive? hiy) (write-char (integer->char hiy))) + (if (positive? eb) (write-char (integer->char eb))) + (if (positive? (+ loy eb hix)) (write-char (integer->char loy))) + (if (positive? hix) (write-char (integer->char hix))) + (write-char (integer->char lox)))) + +(define (tek41:encode-int number) + (let* ((mag (abs number)) + (hi1 (+ (quotient mag 1024) 64)) + (hi2 (+ (modulo (quotient mag 16) 64) 64)) + (lo (+ (modulo mag 16) 32))) + (if (>= number 0) (set! lo (+ lo 16))) + (if (not (= hi1 64)) (write-char (integer->char hi1))) + (if (or (not (= hi2 64)) + (not (= hi1 64))) + (write-char (integer->char hi2))) + (write-char (integer->char lo)))) + +(define (test) + (tek41:init) + (tek41:reset) + (tek41:graphics) + (do ((i 0 (+ 1 i))) + ((> i 15)) + (tek41:linetype i) + (tek41:move (+ (* 200 i) 1000) 1000) + (tek41:draw (+ (* 200 i) 2000) 2000)) + (tek41:text)) diff --git a/time.scm b/time.scm new file mode 100644 index 0000000..7ddf524 --- /dev/null +++ b/time.scm @@ -0,0 +1,158 @@ +;;;; "time.scm" Posix time conversion routines +;;; Copyright (C) 1994 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define time:daylight 0) +(define *timezone* 0) +(define time:tzname #("GMT" "GDT")) + +(define (time:tzset) + (set! time:daylight 1) + (set! *timezone* (* 5 60 60)) + (set! time:tzname #("EST" "EDT"))) + +;;; No, it doesn't do leap seconds. If you want to add it, go ahead. + +;;; Returns the `struct tm' representation of T, +;;; offset TM_GMTOFF seconds east of UCT. +(define (time:split t tm_isdst tm_gmtoff tm_zone) + (set! t (difftime t tm_gmtoff)) + (let* ((days-in-year (lambda (year) + (if (and (zero? (remainder year 4)) + (or (not (zero? (remainder year 100))) + (zero? (remainder year 400)))) + 366 365))) + (days/month #(#(31 28 31 30 31 30 31 31 30 31 30 31) ; Normal years. + #(31 29 31 30 31 30 31 31 30 31 30 31))) ; Leap years. + (SECS/HOUR (* 60 60)) + (SECS/DAY (* SECS/HOUR 24)) + (secs (modulo t SECS/DAY)) + (days (+ (quotient t SECS/DAY) + (if (and (negative? t) (positive? secs)) -1 0)))) + (let ((tm_hour (quotient secs SECS/HOUR)) + (secs (remainder secs SECS/HOUR)) + (tm_wday (modulo (+ 4 days) 7))) ; January 1, 1970 was a Thursday. + (let loop ((tm_year 1970) + (tm_yday days)) + (let ((diy (days-in-year tm_year))) + (cond + ((negative? tm_yday) (loop (+ -1 tm_year) (+ tm_yday diy))) + ((>= tm_yday diy) (loop (+ 1 tm_year) (- tm_yday diy))) + (else + (let* ((mv (vector-ref days/month (- diy 365)))) + (do ((tm_mon 0 (+ 1 tm_mon)) + (tm_mday tm_yday (- tm_mday (vector-ref mv tm_mon)))) + ((< tm_mday (vector-ref mv tm_mon)) + (vector + (remainder secs 60) ; Seconds. [0-61] (2 leap seconds) + (quotient secs 60) ; Minutes. [0-59] + tm_hour ; Hours. [0-23] + (+ tm_mday 1) ; Day. [1-31] + tm_mon ; Month. [0-11] + (- tm_year 1900) ; Year - 1900. + tm_wday ; Day of week. [0-6] + tm_yday ; Days in year. [0-365] + tm_isdst ; DST. [-1/0/1] + tm_gmtoff ; Seconds west of UTC. + tm_zone ; Timezone abbreviation. + ))))))))))) + +(define (time:gmtime t) + (time:split t 0 0 "GMT")) + +(define (time:localtime t) + (time:tzset) + (time:split t time:daylight *timezone* + (vector-ref time:tzname time:daylight))) + +(define time:year-70 + (let* ((t (current-time))) + (offset-time (offset-time t (- (difftime t 0))) (* -70 32140800)))) + +(define (time:invert decoder target) + (let* ((times #(1 60 3600 86400 2678400 32140800)) + (trough ; rough time for target + (do ((i 5 (+ i -1)) + (trough time:year-70 + (offset-time trough (* (vector-ref target i) + (vector-ref times i))))) + ((negative? i) trough)))) +;;; (print 'trough trough 'target target) + (let loop ((guess trough) + (j 0) + (guess-tm (decoder trough))) +;;; (print 'guess guess 'guess-tm guess-tm) + (do ((i 5 (+ i -1)) + (rough time:year-70 + (offset-time rough (* (vector-ref guess-tm i) + (vector-ref times i)))) + (sign (let ((d (- (vector-ref target 5) + (vector-ref guess-tm 5)))) + (and (not (zero? d)) d)) + (or sign + (let ((d (- (vector-ref target i) + (vector-ref guess-tm i)))) + (and (not (zero? d)) d))))) + ((negative? i) + (let* ((distance (abs (- trough rough)))) + (cond ((and (zero? distance) sign) +;;; (print "trying to jump") + (set! distance (if (negative? sign) -86400 86400))) + ((and sign (negative? sign)) (set! distance (- distance)))) + (set! guess (offset-time guess distance)) +;;; (print 'distance distance 'sign sign) + (cond ((zero? distance) guess) + ((> j 5) #f) ;to prevent inf loops. + (else + (loop guess + (+ 1 j) + (decoder guess)))))))))) + +(define (time:mktime time) + (time:tzset) + (time:invert localtime time)) + +(define (time:asctime decoded) + (let ((days #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")) + (months #("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) + (number->2digits + (lambda (n ch) + (set! n (number->string n)) + (if (= 1 (string-length n)) + (string-append ch n) + n)))) + (string-append + (vector-ref days (vector-ref decoded 6)) " " + (vector-ref months (vector-ref decoded 4)) " " + (number->2digits (vector-ref decoded 3) " ") " " + (number->2digits (vector-ref decoded 2) "0") ":" + (number->2digits (vector-ref decoded 1) "0") ":" + (number->2digits (vector-ref decoded 0) "0") " " + (number->string (+ 1900 (vector-ref decoded 5))) + (string #\newline)))) + +(define (time:ctime time) + (time:asctime (time:localtime time))) + +(define tzset time:tzset) +(define gmtime time:gmtime) +(define localtime time:localtime) +(define mktime time:mktime) +(define asctime time:asctime) +(define ctime time:ctime) diff --git a/trace.scm b/trace.scm new file mode 100644 index 0000000..d595277 --- /dev/null +++ b/trace.scm @@ -0,0 +1,106 @@ +;;;; "trace.scm" Utility macros for tracing in Scheme. +;;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'qp) ;for the qp printer. +(define debug:indent 0) + +(define debug:tracef + (let ((null? null?) ;These bindings are so that + (not not) ;tracef will not trace parts + (car car) (cdr cdr) ;of itself. + (eq? eq?) (+ +) (zero? zero?) (modulo modulo) + (apply apply) (display display) (qpn qpn)) + (lambda (function . optname) + (set! debug:indent 0) + (let ((name (if (null? optname) function (car optname)))) + (lambda args + (cond ((and (not (null? args)) + (eq? (car args) 'debug:untrace-object) + (null? (cdr args))) + function) + (else + (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ )) + (apply qpn "CALLED" name args) + (set! debug:indent (modulo (+ 1 debug:indent) 8)) + (let ((ans (apply function args))) + (set! debug:indent (modulo (+ -1 debug:indent) 8)) + (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ )) + (qpn "RETURNED" name ans) + ans)))))))) + +;;; the reason I use a symbol for debug:untrace-object is so +;;; that functions can still be untraced if this file is read in twice. + +(define (debug:untracef function) + (set! debug:indent 0) + (function 'debug:untrace-object)) + +;;;;The trace: functions wrap around the debug: functions to provide +;;; niceties like keeping track of traced functions and dealing with +;;; redefinition. + +(require 'alist) +(define trace:adder (alist-associator eq?)) +(define trace:deler (alist-remover eq?)) + +(define *traced-procedures* '()) +(define (trace:tracef fun sym) + (cond ((not (procedure? fun)) + (display "WARNING: not a procedure " (current-error-port)) + (display sym (current-error-port)) + (newline (current-error-port)) + (set! *traced-procedures* (trace:deler *traced-procedures* sym)) + fun) + (else + (let ((p (assq sym *traced-procedures*))) + (cond ((and p (eq? (cdr p) fun)) + fun) + (else + (let ((tfun (debug:tracef fun sym))) + (set! *traced-procedures* + (trace:adder *traced-procedures* sym tfun)) + tfun))))))) + +(define (trace:untracef fun sym) + (let ((p (assq sym *traced-procedures*))) + (set! *traced-procedures* (trace:deler *traced-procedures* sym)) + (cond ((not (procedure? fun)) fun) + ((not p) fun) + ((eq? (cdr p) fun) + (debug:untracef fun)) + (else fun)))) + +(define tracef debug:tracef) +(define untracef debug:untracef) + +;;;; Finally, the macros trace and untrace + +(defmacro trace xs + (if (null? xs) + `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) + (map car *traced-procedures*)) + (map car *traced-procedures*)) + `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) xs)))) +(defmacro untrace xs + (if (null? xs) + (slib:eval + `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x))) + (map car *traced-procedures*)) + '',(map car *traced-procedures*))) + `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x))) xs)))) diff --git a/tree.scm b/tree.scm new file mode 100644 index 0000000..f400d1b --- /dev/null +++ b/tree.scm @@ -0,0 +1,62 @@ +;;"tree.scm" Implementation of COMMON LISP tree functions for Scheme +; Copyright 1993, 1994 David Love (d.love@dl.ac.uk) +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;; Deep copy of the tree -- new one has all new pairs. (Called +;; tree-copy in Dybvig.) +(define (tree:copy-tree tree) + (if (pair? tree) + (cons (tree:copy-tree (car tree)) + (tree:copy-tree (cdr tree))) + tree)) + +;; Substitute occurrences of old equal? to new in tree. +;; Similar to tree walks in SICP without the internal define. +(define (tree:subst new old tree) + (let walk ((tree tree)) + (cond ((equal? old tree) + new) + ((pair? tree) + (cons (walk (car tree)) + (walk (cdr tree)))) + (else tree)))) + +;; The next 2 aren't in CL. (Names from Dybvig) + +(define (tree:substq new old tree) + (let walk ((tree tree)) + (cond ((eq? old tree) + new) + ((pair? tree) + (cons (walk (car tree)) + (walk (cdr tree)))) + (else tree)))) + +(define (tree:substv new old tree) + (let walk ((tree tree)) + (cond ((eqv? old tree) + new) + ((pair? tree) + (cons (walk (car tree)) + (walk (cdr tree)))) + (else tree)))) + +(define copy-tree tree:copy-tree) +(define subst tree:subst) +(define substq tree:substq) +(define substv tree:substv) diff --git a/trnscrpt.scm b/trnscrpt.scm new file mode 100644 index 0000000..45d884e --- /dev/null +++ b/trnscrpt.scm @@ -0,0 +1,76 @@ +; "trnscrpt.scm", transcript functions for Scheme. +; Copyright (c) 1992, 1993, 1995 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define transcript:port #f) + +(define (transcript-on filename) + (set! transcript:port (open-output-file filename))) + +(define (transcript-off) + (if (output-port? transcript:port) + (close-output-port transcript:port)) + (set! transcript:port #f)) + +(define read-char + (let ((read-char read-char) (write-char write-char)) + (lambda opt + (let ((ans (apply read-char opt))) + (cond ((eof-object? ans)) + ((output-port? transcript:port) + (write-char ans transcript:port))) + ans)))) + +(define read + (let ((read read) (write write) (newline newline)) + (lambda opt + (let ((ans (apply read opt))) + (cond ((eof-object? ans)) + ((output-port? transcript:port) + (write ans transcript:port) + (if (eqv? #\newline (apply peek-char opt)) + (newline transcript:port)))) + ans)))) + +(define write-char + (let ((write-char write-char)) + (lambda (obj . opt) + (apply write-char obj opt) + (if (output-port? transcript:port) + (write-char obj transcript:port))))) + +(define write + (let ((write write)) + (lambda (obj . opt) + (apply write obj opt) + (if (output-port? transcript:port) + (write obj transcript:port))))) + +(define display + (let ((display display)) + (lambda (obj . opt) + (apply display obj opt) + (if (output-port? transcript:port) + (display obj transcript:port))))) + +(define newline + (let ((newline newline)) + (lambda opt + (apply newline opt) + (if (output-port? transcript:port) + (newline transcript:port))))) diff --git a/tsort.scm b/tsort.scm new file mode 100644 index 0000000..9371f3c --- /dev/null +++ b/tsort.scm @@ -0,0 +1,46 @@ +;;; "tsort.scm" Topological sort +;;; Copyright (C) 1995 Mikael Djurfeldt +; +; This code is in the public domain. + +;;; The algorithm is inspired by Cormen, Leiserson and Rivest (1990) +;;; "Introduction to Algorithms", chapter 23 + +(require 'hash-table) +(require 'primes) + +(define (topological-sort dag pred) + (if (null? dag) + '() + (let* ((adj-table (make-hash-table + (car (primes> (length dag) 1)))) + (insert (hash-associator pred)) + (lookup (hash-inquirer pred)) + (sorted '())) + (letrec ((visit + (lambda (u adj-list) + ;; Color vertex u + (insert adj-table u 'colored) + ;; Visit uncolored vertices which u connects to + (for-each (lambda (v) + (let ((val (lookup adj-table v))) + (if (not (eq? val 'colored)) + (visit v (or val '()))))) + adj-list) + ;; Since all vertices downstream u are visited + ;; by now, we can safely put u on the output list + (set! sorted (cons u sorted))))) + ;; Hash adjacency lists + (for-each (lambda (def) + (insert adj-table (car def) (cdr def))) + (cdr dag)) + ;; Visit vertices + (visit (caar dag) (cdar dag)) + (for-each (lambda (def) + (let ((val (lookup adj-table (car def)))) + (if (not (eq? val 'colored)) + (visit (car def) (cdr def))))) + (cdr dag))) + sorted))) + +(define tsort topological-sort) diff --git a/values.scm b/values.scm new file mode 100644 index 0000000..b47e0f8 --- /dev/null +++ b/values.scm @@ -0,0 +1,27 @@ +;"values.scm" multiple values +;By david carlton, carlton@husc.harvard.edu. +; +;This code is in the public domain. + +(require 'record) + +(define values:*values-rtd* + (make-record-type "values" + '(values))) + +(define values + (let ((make-values (record-constructor values:*values-rtd*))) + (lambda x + (if (and (not (null? x)) + (null? (cdr x))) + (car x) + (make-values x))))) + +(define call-with-values + (let ((access-values (record-accessor values:*values-rtd* 'values)) + (values-predicate? (record-predicate values:*values-rtd*))) + (lambda (producer consumer) + (let ((result (producer))) + (if (values-predicate? result) + (apply consumer (access-values result)) + (consumer result)))))) diff --git a/vscm.init b/vscm.init new file mode 100644 index 0000000..7d4661b --- /dev/null +++ b/vscm.init @@ -0,0 +1,306 @@ +;;;"vscm.init" Configuration of *features* for VSCM -*-scheme-*- +;Copyright (C) 1994 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;; From: Matthias Blume +;;; Date: Tue, 1 Mar 1994 11:42:31 -0500 +;;; Disclaimer: The code below is only a quick hack. If I find some +;;; time to spare I might get around to make some more things work. +;;; In particular, string ports could be made available without too +;;; much trouble. + +;;; You have to provide ``vscm.init'' as an explicit command line +;;; argument. Since this is not very nice I would recommend the +;;; following installation procedure: + +;1. run scheme +;2. (load "vscm.init") +;3. (slib:dump "dumpfile") +;3. mv dumpfile place-where-vscm-standard-bootfile-resides, e.g. +; mv dumpfile /usr/local/vscm/lib/scheme-boot +; (In this case vscm should have been compiled with flag +; -DDEFAULT_BOOTFILE='"/usr/local/vscm/lib/scheme-boot"'. See +; Makefile (definition of DDP) for details.) + +(define (slib:dump dump-to-file) + (let ((args (dump dump-to-file))) + (if args + (begin + (display "[SLIB available]") + (newline) + (((mcm) 'toplevel) args)) + (quit)))) + +;;; Caveat: While playing with this code I discovered a nasty bug. +;;; (Something is wrong with my ``restore'' code -- it seems to break +;;; on 64 bit machines (not always, though).) It works on MIPS, etc. + +;;; (software-type) should be set to the generic operating system type. +;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. + +(define (software-type) 'UNIX) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. + +(define (scheme-implementation-type) 'Vscm) + +;;; (scheme-implementation-version) should return a string describing the +;;; version the scheme implementation loading this file. + +(define (scheme-implementation-version) "?") + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. + +(define (implementation-vicinity) + (case (software-type) + ((UNIX) "/usr/local/src/scheme/") + ((VMS) "scheme$src:") + ((MS-DOS) "C:\\scheme\\"))) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +(define library-vicinity + (let ((library-path + (or (getenv "SCHEME_LIBRARY_PATH") + ;; Uses this path if SCHEME_LIBRARY_PATH is not set. + (case (software-type) + ((UNIX) "/usr/local/lib/slib/") + ((VMS) "lib$scheme:") + ((MS-DOS) "C:\\SLIB\\") + (else ""))))) + (lambda () library-path))) + +;;; *FEATURES* should be set to a list of symbols describing features +;;; of this implementation. Suggestions for features are: + +(define *features* + '( + source ;can load scheme source files + ;(slib:load-source "filename") +; compiled ;can load compiled files + ;(slib:load-compiled "filename") + rev4-report ;conforms to +; rev3-report ;conforms to + ieee-p1178 ;conforms to +; sicp ;runs code from Structure and + ;Interpretation of Computer + ;Programs by Abelson and Sussman. + rev4-optional-procedures ;LIST-TAIL, STRING->LIST, + ;LIST->STRING, STRING-COPY, + ;STRING-FILL!, LIST->VECTOR, + ;VECTOR->LIST, and VECTOR-FILL! + rev3-procedures ;LAST-PAIR, T, and NIL +; rev2-procedures ;SUBSTRING-MOVE-LEFT!, + ;SUBSTRING-MOVE-RIGHT!, + ;SUBSTRING-FILL!, + ;STRING-NULL?, APPEND!, 1+, + ;-1+, ?, >=? + multiarg/and- ;/ and - can take more than 2 args. + multiarg-apply ;APPLY can take more than 2 args. + rationalize + delay ;has DELAY and FORCE + with-file ;has WITH-INPUT-FROM-FILE and + ;WITH-OUTPUT-FROM-FILE +; string-port ;has CALL-WITH-INPUT-STRING and + ;CALL-WITH-OUTPUT-STRING +; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF +; char-ready? +; macro ;has R4RS high level macros +; defmacro ;has Common Lisp DEFMACRO + eval ;SLIB:EVAL is single argument eval +; record ;has user defined data structures + values ;proposed multiple values +; dynamic-wind ;proposed dynamic-wind + ieee-floating-point ;conforms to + full-continuation ;can return multiple times +; object-hash ;has OBJECT-HASH + +; sort +; queue ;queues +; pretty-print + object->string +; format +; trace ;has macros: TRACE and UNTRACE +; compiler ;has (COMPILER) +; ed ;(ED) is editor + system ;posix (system ) + getenv ;posix (getenv ) + program-arguments ;returns list of strings (argv) +; Xwindows ;X support +; curses ;screen management package +; termcap ;terminal description package +; terminfo ;sysV terminal description + )) + +;;; (OBJECT->STRING obj) -- analogous to WRITE +(define object->string string-write) + +;;; (PROGRAM-ARGUMENTS) +;;; +(define (program-arguments) command-line-arguments) + +;;; (OUTPUT-PORT-WIDTH ) +(define (output-port-width . arg) 79) + +;;; (CURRENT-ERROR-PORT) +(define current-error-port + (standard-port 2)) + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (string-append "slib_" (number->string cntr))))) + +;;; (FILE-EXISTS? ) +(define (file-exists? f) + (system (string-append "test -f " f))) + +;;; (DELETE-FILE ) +(define (delete-file f) + (remove-file f)) + +;;; FORCE-OUTPUT flushes any pending output on optional arg output port +(define force-output flush) + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-*PUT-FILE. + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +(define char-code-limit 256) + +;;; MOST-POSITIVE-FIXNUM is used in modular.scm +(define most-positive-fixnum #x0fffffff) + +;;; Return argument +(define (identity x) x) + +;;; If your implementation provides eval SLIB:EVAL is single argument +;;; eval using the top-level (user) environment. +(define slib:eval eval) + +;;; If your implementation provides R4RS macros: +(define macro:eval slib:eval) +(define macro:load load) + +(define *defmacros* + (list (cons 'defmacro + (lambda (name parms . body) + `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) + *defmacros*)))))) +(define (defmacro? m) (and (assq m *defmacros*) #t)) + +(define (macroexpand-1 e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) (set! a (assq a *defmacros*)) + (if a (apply (cdr a) (cdr e)) e)) + (else e))) + e)) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) + (set! a (assq a *defmacros*)) + (if a (macroexpand (apply (cdr a) (cdr e))) e)) + (else e))) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +(define base:eval slib:eval) +(define (defmacro:eval x) (base:eval (defmacro:expand* x))) +(define (defmacro:expand* x) + (require 'defmacroexpand) (apply defmacro:expand* x '())) + +(define (defmacro:load ) + (slib:eval-load defmacro:eval)) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;;; define an error procedure for the library +(define slib:error error) + +;;; define these as appropriate for your system. +(define slib:tab #\Tab) +(define slib:form-feed #\d12) + +;;; Support for older versions of Scheme. Not enough code for its own file. +(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) +(define t #t) +(define nil #f) + +;;; Define these if your implementation's syntax can support it and if +;;; they are not already defined. + +(define (1+ n) (+ n 1)) +(define (-1+ n) (+ n -1)) +(define 1- -1+) + +(define in-vicinity string-append) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:exit + (lambda args + (cond ((null? args) (quit)) + ((eqv? #t (car args)) (quit)) + ((eqv? #f (car args)) (quit 1)) + (else (quit (car args)))))) + +;;; Here for backward compatability +(define scheme-file-suffix + (let ((suffix (case (software-type) + ((NOSVE) "_scm") + (else ".scm")))) + (lambda () suffix))) + +;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;; suffix all the module files in SLIB have. See feature 'SOURCE. + +(define (slib:load-source f) (load (string-append f (scheme-file-suffix)))) + +;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;; by compiling "foo.scm" if this implementation can compile files. +;;; See feature 'COMPILED. + +(define slib:load-compiled load) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) + +(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/withfile.scm b/withfile.scm new file mode 100644 index 0000000..fc13510 --- /dev/null +++ b/withfile.scm @@ -0,0 +1,82 @@ +; "withfile.scm", with-input-from-file and with-output-to-file for Scheme +; Copyright (c) 1992, 1993 Aubrey Jaffer +;; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'dynamic-wind) + +(define withfile:current-input (current-input-port)) +(define withfile:current-output (current-output-port)) + +(define (current-input-port) withfile:current-input) +(define (current-output-port) withfile:current-output) + +(define (with-input-from-file file thunk) + (define oport withfile:current-input) + (define port (open-input-file file)) + (dynamic-wind (lambda () (set! oport withfile:current-input) + (set! withfile:current-input port)) + (lambda() (let ((ans (thunk))) (close-input-port port) ans)) + (lambda() (set! withfile:current-input oport)))) + +(define (with-output-from-file file thunk) + (define oport withfile:current-output) + (define port (open-output-file file)) + (dynamic-wind (lambda() (set! oport withfile:current-output) + (set! withfile:current-output port)) + (lambda() (let ((ans (thunk))) (close-output-port port) ans)) + (lambda() (set! withfile:current-output oport)))) + +(define peek-char + (let ((peek-char peek-char)) + (lambda opt + (peek-char (if (null? opt) withfile:current-input (car opt)))))) + +(define read-char + (let ((read-char read-char)) + (lambda opt + (read-char (if (null? opt) withfile:current-input (car opt)))))) + +(define read + (let ((read read)) + (lambda opt + (read (if (null? opt) withfile:current-input (car opt)))))) + +(define write-char + (let ((write-char write-char)) + (lambda (obj . opt) + (write-char obj (if (null? opt) withfile:current-output (car opt)))))) + +(define write + (let ((write write)) + (lambda (obj . opt) + (write obj (if (null? opt) withfile:current-output (car opt)))))) + +(define display + (let ((display display)) + (lambda (obj . opt) + (display obj (if (null? opt) withfile:current-output (car opt)))))) + +(define newline + (let ((newline newline)) + (lambda opt + (newline (if (null? opt) withfile:current-output (car opt)))))) + +(define force-output + (let ((force-output force-output)) + (lambda opt + (force-output (if (null? opt) withfile:current-output (car opt)))))) diff --git a/wttest.scm b/wttest.scm new file mode 100644 index 0000000..cc8b5e3 --- /dev/null +++ b/wttest.scm @@ -0,0 +1,134 @@ +;; "wttrtst.scm" Test Weight balanced trees -*-Scheme-*- +;; Copyright (c) 1993-1994 Stephen Adams +;; +;; Copyright (c) 1993-94 Massachusetts Institute of Technology +;; +;; This material was developed by the Scheme project at the Massachusetts +;; Institute of Technology, Department of Electrical Engineering and +;; Computer Science. Permission to copy this software, to redistribute +;; it, and to use it for any purpose is granted, subject to the following +;; restrictions and understandings. +;; +;; 1. Any copy made of this software must include this copyright notice +;; in full. +;; +;; 2. Users of this software agree to make their best efforts (a) to +;; return to the MIT Scheme project any improvements or extensions that +;; they make, so that these may be included in future releases; and (b) +;; to inform MIT of noteworthy uses of this software. +;; +;; 3. All materials developed as a consequence of the use of this +;; software shall duly acknowledge such use, in accordance with the usual +;; standards of acknowledging credit in academic research. +;; +;; 4. MIT has made no warrantee or representation that the operation of +;; this software will be error-free, and MIT is under no obligation to +;; provide any services, by way of maintenance, update, or otherwise. +;; +;; 5. In conjunction with products arising from the use of this material, +;; there shall be no use of the name of the Massachusetts Institute of +;; Technology nor of any adaptation thereof in any advertising, +;; promotional, or sales literature without prior written consent from +;; MIT in each case. + +(require 'wt-tree) + +;; Test code, using maps from digit strings to the numbers they represent. + +(define (wt-test) + + (define (make-map lo hi step) + (let loop ((i lo) (map (make-wt-tree string-wt-type))) + (if (> i hi) + map + (loop (+ i step) (wt-tree/add map (number->string i) i))))) + + (define (wt-tree->alist t) + (wt-tree/fold (lambda (key datum rest) (cons (cons key datum) rest)) '() t)) + + (define (try-all operation trees) + (map (lambda (t1) + (map (lambda (t2) + (operation t1 t2)) + trees)) + trees)) + + (define (chunk tree) + (let ((size (wt-tree/size tree))) + (if (< size 8) + size + (let* ((midpoint (if (even? size) + (/ size 2) + (/ (+ size 1) 2))) + (fulcrum (wt-tree/index tree midpoint))) + (list (chunk (wt-tree/split< tree fulcrum)) + (list fulcrum) + (chunk (wt-tree/split> tree fulcrum))))))) + + (define (verify name result expected) + (newline) + (display "Test ") (display name) + (if (equal? result expected) + (begin + (display " passed")) + (begin + (display " unexpected result") + (newline) + (display "Expected: " expected) + (newline) + (display "Got: " result)))) + + (let ((t1 (make-map 0 99 2)) ; 0,2,4,...,98 + (t2 (make-map 1 100 2)) ; 1,3,5,...,99 + (t3 (make-map 0 100 3))) ; 0,3,6,...,99 + + + (verify 'alist (wt-tree->alist t3) ; + '(("0" . 0) ("12" . 12) ("15" . 15) ("18" . 18) ("21" . 21) + ("24" . 24) ("27" . 27) ("3" . 3) ("30" . 30) ("33" . 33) + ("36" . 36) ("39" . 39) ("42" . 42) ("45" . 45) ("48" . 48) + ("51" . 51) ("54" . 54) ("57" . 57) ("6" . 6) ("60" . 60) + ("63" . 63) ("66" . 66) ("69" . 69) ("72" . 72) ("75" . 75) + ("78" . 78) ("81" . 81) ("84" . 84) ("87" . 87) ("9" . 9) + ("90" . 90) ("93" . 93) ("96" . 96) ("99" . 99))) + + + (verify 'union-sizes + (try-all (lambda (t1 t2) (wt-tree/size (wt-tree/union t1 t2))) + (list t1 t2 t3)) + '((50 100 67) (100 50 67) (67 67 34))) + + (verify 'difference-sizes + (try-all (lambda (t1 t2) + (wt-tree/size (wt-tree/difference t1 t2))) + (list t1 t2 t3)) + '((0 50 33) (50 0 33) (17 17 0))) + + (verify 'intersection-sizes + (try-all (lambda (t1 t2) + (wt-tree/size (wt-tree/intersection t1 t2))) + (list t1 t2 t3)) + '((50 0 17) (0 50 17) (17 17 34))) + + (verify 'equalities + (try-all (lambda (t1 t2) + (wt-tree/set-equal? (wt-tree/difference t1 t2) + (wt-tree/difference t2 t1))) + (list t1 t2 t3)) + '((#t #f #f) (#f #t #f) (#f #f #t))) + + (verify 'indexing + (chunk (make-map 0 99 1)) + '((((7 ("15") 5) ("20") (6 ("27") 4)) ("31") + ((6 ("38") 5) ("43") (6 ("5") 4))) + ("54") + (((7 ("61") 5) ("67") (6 ("73") 4)) ("78") + ((6 ("84") 5) ("9") (5 ("95") 4))))) + (newline))) + +(wt-test) + +;;; Local Variables: +;;; eval: (put 'with-n-node 'scheme-indent-function 1) +;;; eval: (put 'with-n-node 'scheme-indent-hook 1) +;;; End: diff --git a/wttree.scm b/wttree.scm new file mode 100644 index 0000000..467aa86 --- /dev/null +++ b/wttree.scm @@ -0,0 +1,784 @@ +;; "wttree.scm" Weight balanced trees -*-Scheme-*- +;; Copyright (c) 1993-1994 Stephen Adams +;; +;; $Id: wttree.scm,v 1.1 1994/11/28 21:58:48 adams Exp adams $ +;; +;; References: +;; +;; Stephen Adams, Implemeting Sets Efficiently in a Functional +;; Language, CSTR 92-10, Department of Electronics and Computer +;; Science, University of Southampton, 1992 +;; +;; +;; Copyright (c) 1993-94 Massachusetts Institute of Technology +;; +;; This material was developed by the Scheme project at the Massachusetts +;; Institute of Technology, Department of Electrical Engineering and +;; Computer Science. Permission to copy this software, to redistribute +;; it, and to use it for any purpose is granted, subject to the following +;; restrictions and understandings. +;; +;; 1. Any copy made of this software must include this copyright notice +;; in full. +;; +;; 2. Users of this software agree to make their best efforts (a) to +;; return to the MIT Scheme project any improvements or extensions that +;; they make, so that these may be included in future releases; and (b) +;; to inform MIT of noteworthy uses of this software. +;; +;; 3. All materials developed as a consequence of the use of this +;; software shall duly acknowledge such use, in accordance with the usual +;; standards of acknowledging credit in academic research. +;; +;; 4. MIT has made no warrantee or representation that the operation of +;; this software will be error-free, and MIT is under no obligation to +;; provide any services, by way of maintenance, update, or otherwise. +;; +;; 5. In conjunction with products arising from the use of this material, +;; there shall be no use of the name of the Massachusetts Institute of +;; Technology nor of any adaptation thereof in any advertising, +;; promotional, or sales literature without prior written consent from +;; MIT in each case. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Weight Balanced Binary Trees +;; +;; +;; +;; This file has been modified from the MIT-Scheme library version to +;; make it more standard. The main changes are +;; +;; . The whole thing has been put in a LET as R4RS Scheme has no module +;; system. +;; . The MIT-Scheme define structure operations have been written out by +;; hand. +;; +;; It has been tested on MIT-Scheme, scheme48 and scm4e1 +;; +;; Non-standard procedures: +;; error +;; error:wrong-type-argument +;; error:band-range-argument +;; These are only called when there is an error so it is not critical to +;; have them defined :-) +;; +;; +;; If your system has a compiler and you want this code to run fast, you +;; should do whatever is necessary to inline all of the structure accessors. +;; +;; This is MIT-Scheme's way of saying that +, car etc should all be inlined. +;; +;;(declare (usual-integrations)) + + +;;; +;;; Interface to this package. +;;; +;;; ONLY these procedures (and TEST at the end of the file) will be +;;; (re)defined in your system. +;;; + +(define make-wt-tree-type #f) +(define number-wt-type #f) +(define string-wt-type #f) + +(define make-wt-tree #f) +(define singleton-wt-tree #f) +(define alist->wt-tree #f) +(define wt-tree/empty? #f) +(define wt-tree/size #f) +(define wt-tree/add #f) +(define wt-tree/delete #f) +(define wt-tree/add! #f) +(define wt-tree/delete! #f) +(define wt-tree/member? #f) +(define wt-tree/lookup #f) +(define wt-tree/split< #f) +(define wt-tree/split> #f) +(define wt-tree/union #f) +(define wt-tree/intersection #f) +(define wt-tree/difference #f) +(define wt-tree/subset? #f) +(define wt-tree/set-equal? #f) +(define wt-tree/fold #f) +(define wt-tree/for-each #f) +(define wt-tree/index #f) +(define wt-tree/index-datum #f) +(define wt-tree/index-pair #f) +(define wt-tree/rank #f) +(define wt-tree/min #f) +(define wt-tree/min-datum #f) +(define wt-tree/min-pair #f) +(define wt-tree/delete-min #f) +(define wt-tree/delete-min! #f) + + +;; This LET sets all of the above variables. + +(let () + + ;; We use the folowing MIT-Scheme operation on fixnums (small + ;; integers). R4RS compatible (but less efficient) definitions. + ;; You should replace these with something that is efficient in your + ;; system. + + (define fix:fixnum? (lambda (x) (and (exact? x) (integer? x)))) + (define fix:+ +) + (define fix:- -) + (define fix:< <) + (define fix:<= <) + (define fix:> >) + (define fix:* *) + + ;; A TREE-TYPE is a collection of those procedures that depend on the + ;; ordering relation. + + ;; MIT-Scheme structure definition + ;;(define-structure + ;; (tree-type + ;; (conc-name tree-type/) + ;; (constructor %make-tree-type)) + ;; (keytree #F read-only true) + ;; (add #F read-only true) + ;; (insert! #F read-only true) + ;; (delete #F read-only true) + ;; (delete! #F read-only true) + ;; (member? #F read-only true) + ;; (lookup #F read-only true) + ;; (split-lt #F read-only true) + ;; (split-gt #F read-only true) + ;; (union #F read-only true) + ;; (intersection #F read-only true) + ;; (difference #F read-only true) + ;; (subset? #F read-only true) + ;; (rank #F read-only true) + ;;) + + ;; Written out by hand, using vectors: + ;; + ;; If possible, you should teach your system to print out something + ;; like #[tree-type <] instread of the whole vector. + + (define tag:tree-type (string->symbol "#[(runtime wttree)tree-type]")) + + (define (%make-tree-type keytree + add insert! + delete delete! + member? lookup + split-lt split-gt + union intersection + difference subset? + rank ) + (vector tag:tree-type + keytree add insert! + delete delete! member? lookup + split-lt split-gt union intersection + difference subset? rank )) + + (define (tree-type? tt) + (and (vector? tt) + (eq? (vector-ref tt 0) tag:tree-type))) + + (define (tree-type/keytree tt) (vector-ref tt 2)) + (define (tree-type/add tt) (vector-ref tt 3)) + (define (tree-type/insert! tt) (vector-ref tt 4)) + (define (tree-type/delete tt) (vector-ref tt 5)) + (define (tree-type/delete! tt) (vector-ref tt 6)) + (define (tree-type/member? tt) (vector-ref tt 7)) + (define (tree-type/lookup tt) (vector-ref tt 8)) + (define (tree-type/split-lt tt) (vector-ref tt 9)) + (define (tree-type/split-gt tt) (vector-ref tt 10)) + (define (tree-type/union tt) (vector-ref tt 11)) + (define (tree-type/intersection tt) (vector-ref tt 12)) + (define (tree-type/difference tt) (vector-ref tt 13)) + (define (tree-type/subset? tt) (vector-ref tt 14)) + (define (tree-type/rank tt) (vector-ref tt 15)) + + ;; User level tree representation. + ;; + ;; WT-TREE is a wrapper for trees of nodes. + ;; + ;;MIT-Scheme: + ;;(define-structure + ;; (wt-tree + ;; (conc-name tree/) + ;; (constructor %make-wt-tree)) + ;; (type #F read-only true) + ;; (root #F read-only false)) + + ;; If possible, you should teach your system to print out something + ;; like #[wt-tree] instread of the whole vector. + + (define tag:wt-tree (string->symbol "#[(runtime wttree)wt-tree]")) + + (define (%make-wt-tree type root) + (vector tag:wt-tree type root)) + + (define (wt-tree? t) + (and (vector? t) + (eq? (vector-ref t 0) tag:wt-tree))) + + (define (tree/type t) (vector-ref t 1)) + (define (tree/root t) (vector-ref t 2)) + (define (set-tree/root! t v) (vector-set! t 2 v)) + + ;; Nodes are the thing from which the real trees are built. There are + ;; lots of these and the uninquisitibe user will never see them, so + ;; they are represented as untagged to save the slot that would be + ;; used for tagging structures. + ;; In MIT-Scheme these were all DEFINE-INTEGRABLE + + (define (make-node k v l r w) (vector w l k r v)) + (define (node/k node) (vector-ref node 2)) + (define (node/v node) (vector-ref node 4)) + (define (node/l node) (vector-ref node 1)) + (define (node/r node) (vector-ref node 3)) + (define (node/w node) (vector-ref node 0)) + + (define empty 'empty) + (define (empty? x) (eq? x 'empty)) + + (define (node/size node) + (if (empty? node) 0 (node/w node))) + + (define (node/singleton k v) (make-node k v empty empty 1)) + + (define (with-n-node node receiver) + (receiver (node/k node) (node/v node) (node/l node) (node/r node))) + + ;; + ;; Constructors for building node trees of various complexity + ;; + + (define (n-join k v l r) + (make-node k v l r (fix:+ 1 (fix:+ (node/size l) (node/size r))))) + + (define (single-l a.k a.v x r) + (with-n-node r + (lambda (b.k b.v y z) (n-join b.k b.v (n-join a.k a.v x y) z)))) + + (define (double-l a.k a.v x r) + (with-n-node r + (lambda (c.k c.v r.l z) + (with-n-node r.l + (lambda (b.k b.v y1 y2) + (n-join b.k b.v + (n-join a.k a.v x y1) + (n-join c.k c.v y2 z))))))) + + (define (single-r b.k b.v l z) + (with-n-node l + (lambda (a.k a.v x y) (n-join a.k a.v x (n-join b.k b.v y z))))) + + (define (double-r c.k c.v l z) + (with-n-node l + (lambda (a.k a.v x l.r) + (with-n-node l.r + (lambda (b.k b.v y1 y2) + (n-join b.k b.v + (n-join a.k a.v x y1) + (n-join c.k c.v y2 z))))))) + + ;; (define-integrable wt-tree-ratio 5) + (define wt-tree-ratio 5) + + (define (t-join k v l r) + (define (simple-join) (n-join k v l r)) + (let ((l.n (node/size l)) + (r.n (node/size r))) + (cond ((fix:< (fix:+ l.n r.n) 2) (simple-join)) + ((fix:> r.n (fix:* wt-tree-ratio l.n)) + ;; right is too big + (let ((r.l.n (node/size (node/l r))) + (r.r.n (node/size (node/r r)))) + (if (fix:< r.l.n r.r.n) + (single-l k v l r) + (double-l k v l r)))) + ((fix:> l.n (fix:* wt-tree-ratio r.n)) + ;; left is too big + (let ((l.l.n (node/size (node/l l))) + (l.r.n (node/size (node/r l)))) + (if (fix:< l.r.n l.l.n) + (single-r k v l r) + (double-r k v l r)))) + (else + (simple-join))))) + ;; + ;; Node tree procedures that are independent of key index size.l) (loop (node/r node) + (fix:- index (fix:+ 1 size.l)))) + (else node)))) + (let ((bound (node/size node))) + (if (or (< index 0) + (>= index bound) + (not (fix:fixnum? index))) + (error:bad-range-argument index 'node/index) + (loop node index)))) + + (define (error:empty owner) + (error "Operation requires non-empty tree:" owner)) + + + (define (local:make-wt-tree-type key? x y) (key? x y) (key? k (node/k node)) + (node/rank k (node/r node) + (fix:+ 1 (fix:+ rank (node/size (node/l node)))))) + (else (fix:+ rank (node/size (node/l node)))))) + + (define (node/add node k v) + (if (empty? node) + (node/singleton k v) + (with-n-node node + (lambda (key val l r) + (cond ((key? k (node/k tree2)) + (and (node/subset? r (node/r tree2)) + (node/find k tree2) + (node/subset? l tree2))) + (else + (and (node/subset? l (node/l tree2)) + (node/subset? r (node/r tree2)))))))))) + + + ;;; Tree interface: stripping off or injecting the tree types + + (define (tree/map-add tree k v) + (%make-wt-tree (tree/type tree) + (node/add (tree/root tree) k v))) + + (define (tree/insert! tree k v) + (set-tree/root! tree (node/add (tree/root tree) k v))) + + (define (tree/delete tree k) + (%make-wt-tree (tree/type tree) + (node/delete k (tree/root tree)))) + + (define (tree/delete! tree k) + (set-tree/root! tree (node/delete k (tree/root tree)))) + + (define (tree/split-lt tree key) + (%make-wt-tree (tree/type tree) + (node/split-lt (tree/root tree) key))) + + (define (tree/split-gt tree key) + (%make-wt-tree (tree/type tree) + (node/split-gt (tree/root tree) key))) + + (define (tree/union tree1 tree2) + (%make-wt-tree (tree/type tree1) + (node/union (tree/root tree1) (tree/root tree2)))) + + (define (tree/intersection tree1 tree2) + (%make-wt-tree (tree/type tree1) + (node/intersection (tree/root tree1) (tree/root tree2)))) + + (define (tree/difference tree1 tree2) + (%make-wt-tree (tree/type tree1) + (node/difference (tree/root tree1) (tree/root tree2)))) + + (define (tree/subset? tree1 tree2) + (node/subset? (tree/root tree1) (tree/root tree2))) + + (define (alist->tree alist) + (define (loop alist node) + (cond ((null? alist) node) + ((pair? alist) (loop (cdr alist) + (node/add node (caar alist) (cdar alist)))) + (else + (error:wrong-type-argument alist "alist" 'alist->tree)))) + (%make-wt-tree my-type (loop alist empty))) + + (define (tree/get tree key default) + (let ((node (node/find key (tree/root tree)))) + (if node + (node/v node) + default))) + + (define (tree/rank tree key) (node/rank key (tree/root tree) 0)) + + (define (tree/member? key tree) + (and (node/find key (tree/root tree)) + #t)) + + (define my-type #F) + + (set! my-type + (%make-tree-type + keytree ; alist->tree + tree/map-add ; add + tree/insert! ; insert! + tree/delete ; delete + tree/delete! ; delete! + tree/member? ; member? + tree/get ; lookup + tree/split-lt ; split-lt + tree/split-gt ; split-gt + tree/union ; union + tree/intersection ; intersection + tree/difference ; difference + tree/subset? ; subset? + tree/rank ; rank + )) + + my-type) + + (define (guarantee-tree tree procedure) + (if (not (wt-tree? tree)) + (error:wrong-type-argument tree "weight-balanced tree" procedure))) + + (define (guarantee-tree-type type procedure) + (if (not (tree-type? type)) + (error:wrong-type-argument type "weight-balanced tree type" procedure))) + + (define (guarantee-compatible-trees tree1 tree2 procedure) + (guarantee-tree tree1 procedure) + (guarantee-tree tree2 procedure) + (if (not (eq? (tree/type tree1) (tree/type tree2))) + (error "The trees" tree1 'and tree2 'have 'incompatible 'types + (tree/type tree1) 'and (tree/type tree2)))) + +;;;______________________________________________________________________ +;;; +;;; Export interface +;;; + (set! make-wt-tree-type local:make-wt-tree-type) + + (set! make-wt-tree + (lambda (tree-type) + (%make-wt-tree tree-type empty))) + + (set! singleton-wt-tree + (lambda (type key value) + (guarantee-tree-type type 'singleton-wt-tree) + (%make-wt-tree type (node/singleton key value)))) + + (set! alist->wt-tree + (lambda (type alist) + (guarantee-tree-type type 'alist->wt-tree) + ((tree-type/alist->tree type) alist))) + + (set! wt-tree/empty? + (lambda (tree) + (guarantee-tree tree 'wt-tree/empty?) + (empty? (tree/root tree)))) + + (set! wt-tree/size + (lambda (tree) + (guarantee-tree tree 'wt-tree/size) + (node/size (tree/root tree)))) + + (set! wt-tree/add + (lambda (tree key datum) + (guarantee-tree tree 'wt-tree/add) + ((tree-type/add (tree/type tree)) tree key datum))) + + (set! wt-tree/delete + (lambda (tree key) + (guarantee-tree tree 'wt-tree/delete) + ((tree-type/delete (tree/type tree)) tree key))) + + (set! wt-tree/add! + (lambda (tree key datum) + (guarantee-tree tree 'wt-tree/add!) + ((tree-type/insert! (tree/type tree)) tree key datum))) + + (set! wt-tree/delete! + (lambda (tree key) + (guarantee-tree tree 'wt-tree/delete!) + ((tree-type/delete! (tree/type tree)) tree key))) + + (set! wt-tree/member? + (lambda (key tree) + (guarantee-tree tree 'wt-tree/member?) + ((tree-type/member? (tree/type tree)) key tree))) + + (set! wt-tree/lookup + (lambda (tree key default) + (guarantee-tree tree 'wt-tree/lookup) + ((tree-type/lookup (tree/type tree)) tree key default))) + + (set! wt-tree/split< + (lambda (tree key) + (guarantee-tree tree 'wt-tree/split<) + ((tree-type/split-lt (tree/type tree)) tree key))) + + (set! wt-tree/split> + (lambda (tree key) + (guarantee-tree tree 'wt-tree/split>) + ((tree-type/split-gt (tree/type tree)) tree key))) + + (set! wt-tree/union + (lambda (tree1 tree2) + (guarantee-compatible-trees tree1 tree2 'wt-tree/union) + ((tree-type/union (tree/type tree1)) tree1 tree2))) + + (set! wt-tree/intersection + (lambda (tree1 tree2) + (guarantee-compatible-trees tree1 tree2 'wt-tree/intersection) + ((tree-type/intersection (tree/type tree1)) tree1 tree2))) + + (set! wt-tree/difference + (lambda (tree1 tree2) + (guarantee-compatible-trees tree1 tree2 'wt-tree/difference) + ((tree-type/difference (tree/type tree1)) tree1 tree2))) + + (set! wt-tree/subset? + (lambda (tree1 tree2) + (guarantee-compatible-trees tree1 tree2 'wt-tree/subset?) + ((tree-type/subset? (tree/type tree1)) tree1 tree2))) + + (set! wt-tree/set-equal? + (lambda (tree1 tree2) + (and (wt-tree/subset? tree1 tree2) + (wt-tree/subset? tree2 tree1)))) + + (set! wt-tree/fold + (lambda (combiner-key-datum-result init tree) + (guarantee-tree tree 'wt-tree/fold) + (node/inorder-fold combiner-key-datum-result + init + (tree/root tree)))) + + (set! wt-tree/for-each + (lambda (action-key-datum tree) + (guarantee-tree tree 'wt-tree/for-each) + (node/for-each action-key-datum (tree/root tree)))) + + (set! wt-tree/index + (lambda (tree index) + (guarantee-tree tree 'wt-tree/index) + (let ((node (node/index (tree/root tree) index))) + (and node (node/k node))))) + + (set! wt-tree/index-datum + (lambda (tree index) + (guarantee-tree tree 'wt-tree/index-datum) + (let ((node (node/index (tree/root tree) index))) + (and node (node/v node))))) + + (set! wt-tree/index-pair + (lambda (tree index) + (guarantee-tree tree 'wt-tree/index-pair) + (let ((node (node/index (tree/root tree) index))) + (and node (cons (node/k node) (node/v node)))))) + + (set! wt-tree/rank + (lambda (tree key) + (guarantee-tree tree 'wt-tree/rank) + ((tree-type/rank (tree/type tree)) tree key))) + + (set! wt-tree/min + (lambda (tree) + (guarantee-tree tree 'wt-tree/min) + (node/k (node/min (tree/root tree))))) + + (set! wt-tree/min-datum + (lambda (tree) + (guarantee-tree tree 'wt-tree/min-datum) + (node/v (node/min (tree/root tree))))) + + (set! wt-tree/min-pair + (lambda (tree) + (guarantee-tree tree 'wt-tree/min-pair) + (let ((node (node/min (tree/root tree)))) + (cons (node/k node) (node/v node))))) + + (set! wt-tree/delete-min + (lambda (tree) + (guarantee-tree tree 'wt-tree/delete-min) + (%make-wt-tree (tree/type tree) + (node/delmin (tree/root tree))))) + + (set! wt-tree/delete-min! + (lambda (tree) + (guarantee-tree tree 'wt-tree/delete-min!) + (set-tree/root! tree (node/delmin (tree/root tree))))) + + ;; < is a lexpr. Many compilers can open-code < so the lambda is faster + ;; than passing <. + (set! number-wt-type (local:make-wt-tree-type (lambda (u v) (< u v)))) + (set! string-wt-type (local:make-wt-tree-type string ...) ...) + ;;=> + (define (make-generic-method + (lambda ( ...) ...)))) + + ((define-operation ( ...) ) ;; no body + ;;=> + (define-operation ( ...) + (slib:error "Operation not handled" + ' + (format #f (if (yasos:instance? ) "#" "~s") + )))))) + +;; DEFINE-PREDICATE + +(define-syntax define-predicate + (syntax-rules () + ((define-predicate ) + ;;=> + (define (make-generic-predicate))))) + +;; OBJECT + +(define-syntax object + (syntax-rules () + ((object (( ...) ...) ...) + ;;=> + (let ((self (make-object))) + (make-method! self (lambda ( ...) ...)) + ... + self)))) + +;; OBJECT with MULTIPLE INHERITANCE {First Found Rule} + +(define-syntax object-with-ancestors + (syntax-rules () + ((object-with-ancestors ( ( ) ... ) + (( ...) ...) ...) + ;;=> + (let* (( ) + ... + (self (make-object ...))) + (make-method! self (lambda ( ...) ...)) + ... + self)))) + +;; OPERATE-AS {a.k.a. send-to-super} + +; used in operations/methods + +(define-syntax operate-as + (syntax-rules () + ((operate-as ...) ;; What is ??? + ;;=> + ((get-method ) ...)))) + + + +;; SET & SETTER + + +(define-syntax set + (syntax-rules () + ((set ( ...) ) + ((yasos:setter ) ... ) + ) + ((set ) + (set! ) + ) +) ) + + +(define yasos:add-setter 'bogus) +(define yasos:remove-setter-for 'bogus) + +(define yasos:setter + (let ( (known-setters (list (cons car set-car!) + (cons cdr set-cdr!) + (cons vector-ref vector-set!) + (cons string-ref string-set!)) + ) + (added-setters '()) + ) + + (set! YASOS:ADD-SETTER + (lambda (getter setter) + (set! added-setters (cons (cons getter setter) added-setters))) + ) + (set! YASOS:REMOVE-SETTER-FOR + (lambda (getter) + (cond + ((null? added-setters) + (slib:error "REMOVE-SETTER-FOR: Unknown getter" getter) + ) + ((eq? getter (caar added-setters)) + (set! added-setters (cdr added-setters)) + ) + (else + (let loop ((x added-setters) (y (cdr added-setters))) + (cond + ((null? y) (slib:error "REMOVE-SETTER-FOR: Unknown getter" + getter)) + ((eq? getter (caar y)) (set-cdr! x (cdr y))) + (else (loop (cdr x) (cdr y))) + ) ) ) + ) ) ) + + (letrec ( (self + (lambda (proc-or-operation) + (cond ((assq proc-or-operation known-setters) => cdr) + ((assq proc-or-operation added-setters) => cdr) + (else (proc-or-operation self))) ) + ) ) + self) +) ) + + + +(define (yasos:make-access-operation ) + (letrec ( (setter-dispatch + (lambda (inst . args) + (cond + ((and (yasos:instance? inst) + (get-method inst setter-dispatch)) + => (lambda (method) (apply method (cons inst args))) + ) + (else #f))) + ) + (self + (lambda (inst . args) + (cond + ((eq? inst yasos:setter) setter-dispatch) ; for (setter self) + ((and (yasos:instance? inst) + (get-method inst self)) + => (lambda (method) (apply method (cons inst args))) + ) + (else (slib:error "Operation not handled" inst)) + ) ) + ) + ) + + self +) ) + +(define-syntax define-access-operation + (syntax-rules () + ((define-access-operation ) + ;=> + (define (yasos:make-access-operation ')) +) ) ) + + + +;;--------------------- +;; general operations +;;--------------------- + +(define-operation (yasos:print obj port) + (format port + ;; if an instance does not have a PRINT operation.. + (if (yasos:instance? obj) "#" "~s") + obj +) ) + +(define-operation (yasos:size obj) + ;; default behavior + (cond + ((vector? obj) (vector-length obj)) + ((list? obj) (length obj)) + ((pair? obj) 2) + ((string? obj) (string-length obj)) + ((char? obj) 1) + (else + (slib:error "Operation not supported: size" obj)) +) ) + +(require 'format) + +;;; exports: + +(define print yasos:print) ; print also in debug.scm +(define size yasos:size) +(define add-setter yasos:add-setter) +(define remove-setter-for yasos:remove-setter-for) +(define setter yasos:setter) + +(provide 'oop) ;in case we were loaded this way. +(provide 'yasos) -- cgit v1.2.3