summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit8ffbc2df0fde83082610149d24e594c1cd879f4a (patch)
treea2be9aad5101c5e450ad141d15c514bc9c2a2963
downloadslib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz
slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip
Import Upstream version 2a6upstream/2a6
-rw-r--r--ANNOUNCE70
-rw-r--r--ChangeLog1094
-rw-r--r--FAQ216
-rw-r--r--Makefile229
-rw-r--r--README220
-rw-r--r--Template.scm267
-rw-r--r--alist.scm66
-rw-r--r--alistab.scm227
-rw-r--r--array.scm279
-rw-r--r--arraymap.scm76
-rw-r--r--batch.scm417
-rw-r--r--break.scm151
-rw-r--r--chap.scm150
-rw-r--r--charplot.scm142
-rw-r--r--chez.init266
-rw-r--r--cltime.scm74
-rw-r--r--collect.scm236
-rw-r--r--comlist.scm326
-rw-r--r--comparse.scm92
-rw-r--r--dbrowse.scm98
-rw-r--r--dbutil.scm222
-rw-r--r--debug.scm78
-rw-r--r--defmacex.scm96
-rw-r--r--dwindtst.scm80
-rw-r--r--dynamic.scm75
-rw-r--r--dynwind.scm74
-rw-r--r--elk.init281
-rw-r--r--factor.scm149
-rw-r--r--fluidlet.scm45
-rw-r--r--format.scm1678
-rw-r--r--formatst.scm647
-rw-r--r--gambit.init219
-rw-r--r--genwrite.scm264
-rw-r--r--getopt.scm80
-rw-r--r--hash.scm153
-rw-r--r--hashtab.scm79
-rw-r--r--lineio.scm50
-rw-r--r--logical.scm150
-rw-r--r--macrotst.scm54
-rw-r--r--macscheme.init265
-rw-r--r--macwork.scm126
-rw-r--r--makcrc.scm86
-rw-r--r--mbe.scm362
-rw-r--r--mitcomp.pat1466
-rw-r--r--mitscheme.init254
-rw-r--r--modular.scm158
-rw-r--r--mulapply.scm28
-rw-r--r--mularg.scm10
-rw-r--r--mwdenote.scm273
-rw-r--r--mwexpand.scm548
-rw-r--r--mwsynrul.scm343
-rw-r--r--obj2str.scm61
-rw-r--r--object.scm97
-rw-r--r--paramlst.scm215
-rw-r--r--plottest.scm47
-rw-r--r--pp.scm12
-rw-r--r--ppfile.scm70
-rw-r--r--primes.scm181
-rw-r--r--printf.scm278
-rw-r--r--priorque.scm141
-rw-r--r--process.scm68
-rw-r--r--promise.scm29
-rw-r--r--qp.scm149
-rw-r--r--queue.scm72
-rw-r--r--r4rsyn.scm542
-rw-r--r--randinex.scm99
-rw-r--r--random.scm101
-rw-r--r--ratize.scm13
-rw-r--r--rdms.scm598
-rw-r--r--recobj.scm54
-rw-r--r--record.scm211
-rw-r--r--repl.scm92
-rw-r--r--report.scm116
-rw-r--r--require.scm348
-rw-r--r--root.scm149
-rw-r--r--sc2.scm66
-rw-r--r--sc4opt.scm53
-rw-r--r--sc4sc3.scm35
-rw-r--r--scaexpp.scm2956
-rw-r--r--scaglob.scm32
-rw-r--r--scainit.scm103
-rw-r--r--scamacr.scm181
-rw-r--r--scanf.scm351
-rw-r--r--scaoutp.scm93
-rw-r--r--scheme2c.init291
-rw-r--r--scheme48.init239
-rw-r--r--scmacro.scm119
-rw-r--r--scmactst.scm160
-rw-r--r--sierpinski.scm71
-rw-r--r--slib.info153
-rw-r--r--slib.info-11306
-rw-r--r--slib.info-21193
-rw-r--r--slib.info-3859
-rw-r--r--slib.info-41248
-rw-r--r--slib.info-51536
-rw-r--r--slib.info-61410
-rw-r--r--slib.info-7615
-rw-r--r--slib.info-8570
-rw-r--r--slib.texi9058
-rw-r--r--sort.scm154
-rw-r--r--soundex.scm82
-rw-r--r--stdio.scm7
-rw-r--r--strcase.scm45
-rw-r--r--strport.scm51
-rw-r--r--strsrch.scm95
-rw-r--r--struct.scm165
-rw-r--r--structst.scm37
-rw-r--r--structure.scm80
-rw-r--r--syncase.sh146
-rw-r--r--synchk.scm104
-rw-r--r--synclo.scm748
-rw-r--r--synrul.scm327
-rw-r--r--t3.init425
-rw-r--r--tek40.scm92
-rw-r--r--tek41.scm147
-rw-r--r--time.scm158
-rw-r--r--trace.scm106
-rw-r--r--tree.scm62
-rw-r--r--trnscrpt.scm76
-rw-r--r--tsort.scm46
-rw-r--r--values.scm27
-rw-r--r--vscm.init306
-rw-r--r--withfile.scm82
-rw-r--r--wttest.scm134
-rw-r--r--wttree.scm784
-rw-r--r--yasyn.scm201
126 files changed, 44217 insertions, 0 deletions
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 <jaffer@jacal.bertronics>
+
+ * 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 <jaffer@jacal.bertronics>
+
+ * rbtest.scm rbtree.scm: removed for lack of copying permissions.
+
+Wed Jun 5 00:22:33 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * 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 <jaffer@jacal.bertronics>
+
+ * 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 <jaffer@jacal.bertronics>
+
+ * 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 <leavens@cs.iastate.edu>
+
+ * 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 <jaffer@jacal.bertronics>
+
+ * 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 <jaffer@jacal.bertronics>
+
+ * 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 <jaffer@jacal.bertronics>
+
+ * slib2a4 released.
+
+Sat Mar 9 21:36:19 1996 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * tsort.scm (topological-sort): Added.
+
+Fri Mar 8 19:25:52 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * printf.scm: Removed use of string-ports. Cleaned up error
+ handling.
+
+Tue Mar 5 14:30:09 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * printf.scm (%a %A): General scheme output specifier added.
+
+Mon Feb 19 15:48:06 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * 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 <jaffer@jacal.bertronics>
+
+ * printf.scm (stdio:iprintf): Rewrote for Posix compliance (+
+ extensions which are both BSD and GNU).
+
+Sat Jan 27 09:55:03 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * 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 <jaffer@jacal.bertronics>
+
+ * 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 <adams@martigny.ai.mit.edu>
+
+ * wttest.scm wttree.scm: Weight Balanced Trees added.
+
+Sun Aug 20 16:06:20 1995 Dave Love <d.love@dl.ac.uk>
+
+ * 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 <mafm@cs.uwa.edu.au>
+
+ * 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 <tromey@drip.colorado.edu>
+
+ * 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 <Tommy.Thorn@irisa.fr>
+ * 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<? s1 s2) (chap:next-string s)): Functions
+ for "chapter ordering" of strings.
+
+Mon Jun 20 22:36:44 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * slib.texi (R4RS Macros section): added.
+
+ From: jjb@isye.gatech.edu (John Bartholdi)
+ * sierpinski.scm (MAKE-SIERPINSKI-INDEXER): added.
+ * soundex.scm (SOUNDEX): added.
+
+ From: hugh@cosc.canterbury.ac.nz (Hugh Emberson)
+ * mwexpand.scm ((mw:quasiquote exp env)): Fixed bug which occured
+ when mw:quasiquote expanded things like `(1 2 3 . ,(+ 1 a)). I
+ added support for vectors in quasiquotes while I was there.
+
+Sun Jun 19 00:37:09 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * defmacex.scm ((defmacro:expand* e)): fixed problem with varargs
+ define.
+
+Sat Jun 18 13:08:33 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * randinex.scm ((random:size-float l x)): no longer assumes that
+ inexact numbers have finite precision, which is not necessarily
+ true (pointed out by jar@ai.mit.edu). Limits size to 4.
+
+Mon Jun 6 00:46:48 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * trace.scm (trace untrace): created.
+ (debug:tracef debug:untracef): moved from debug.scm
+
+Sun May 22 23:44:03 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * yasyn.scm: replaces yasos.scm
+
+Sat May 21 22:28:01 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * comlist.scm ((comlist:has-duplicates? lst)): added.
+
+Mon May 16 13:40:18 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: jjb@isye.gatech.edu (John Bartholdi)
+ * macscheme.init (slib:exit): fixed. Version set to 4.2.
+
+Wed Apr 27 00:48:54 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: jjb@isye.gatech.edu (John Bartholdi)
+ * scanf.scm (scanf fscanf sscanf): created.
+
+Thu Apr 14 12:59:41 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: pegelow@moorea.uni-muenster.de (Ulrich Pegelow)
+ * mbe.scm (hyg:tag-do): Scoping was wrong. The region of binding
+ of a <variable> did not include the <step> expression and the
+ <test> expression, instead it incorrectly included the <init>
+ 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 <pathname> 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 <blume@cs.Princeton.EDU>
+ * 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 <d.love@daresbury.ac.uk>
+ * 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 <will@skinner.cs.uoregon.edu>
+ * 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 <d.love@daresbury.ac.uk>
+ * 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" <dfried@cs.indiana.edu>
+ * 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 #<unspecified>
+ * ~: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 <rpg@rex.cs.tulane.edu>
+ * 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 <bevan@computer-science.manchester.ac.uk>
+ * 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 <bevan@cs.man.ac.uk> 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" <cph@martigny.ai.mit.edu>
+ * 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" <cph@martigny.ai.mit.edu>
+ * 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
+ <carlton@husc.harvard.edu>. 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 <string>)
+ getenv ;posix (getenv <string>)
+; 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 <port>)
+(define (output-port-width . arg) 79)
+
+;;; (OUTPUT-PORT-HEIGHT <port>)
+(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? <string>)
+(define (file-exists? f) #f)
+
+;;; (DELETE-FILE <string>)
+(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 <pathname>)
+ (slib:eval-load <pathname> defmacro:eval))
+
+(define (slib:eval-load <pathname> evl)
+ (if (not (file-exists? <pathname>))
+ (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <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) (string<? x y))
+ ((key-< (car x) (car y)) #t)
+ ((key-< (car y) (car x)) #f)
+ (else (key-< (cdr x) (cdr y)))))
+ (require 'sort)
+ (for-each operation
+ (map cdr (sort! (map (lambda (p) (cons (key->sortable (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<? s1 s2)
+ (let ((l1 (string-length s1))
+ (l2 (string-length s2)))
+ (define (match-so-far i ctypep)
+ (cond ((>= 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<? c1 c2))
+ #f))
+ ((ctypep c2) #t)
+ (else
+ (let ((ctype1 (ctype c1)))
+ (cond
+ ((and ctype1 (eq? ctype1 (ctype c2)))
+ (length-race (+ 1 i) ctype1 (char<? c1 c2)))
+ (else (char<? c1 c2))))))))))
+ (define (length-race i ctypep def)
+ (cond ((>= 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 (char<? c1 c2)))
+ (else (char<? c1 c2)))))))
+ (delimited 0)))
+
+(define chap:char-incr (- (char->integer #\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<? s1 s2))
+; (s> (chap:string<? s2 s1)))
+; (cond (s<
+; (display s1)
+; (display " < ")
+; (display s2)
+; (newline)))
+; (cond (s>
+; (display s1)
+; (display " > ")
+; (display s2)
+; (newline)))))
+
+(define (chap:string>? s1 s2) (chap:string<? s2 s1))
+(define (chap:string>=? s1 s2) (not (chap:string<? s1 s2)))
+(define (chap:string<=? s1 s2) (not (chap:string<? s2 s1)))
diff --git a/charplot.scm b/charplot.scm
new file mode 100644
index 0000000..2a2a49a
--- /dev/null
+++ b/charplot.scm
@@ -0,0 +1,142 @@
+;;;; "charplot.scm", plotting on character devices 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 'sort)
+
+(define charplot:rows 24)
+(define charplot:columns (output-port-width (current-output-port)))
+
+(define charplot:xborder #\_)
+(define charplot:yborder #\|)
+(define charplot:xaxchar #\-)
+(define charplot:yaxchar #\:)
+(define charplot:curve1 #\*)
+(define charplot:xtick #\.)
+
+(define charplot:height (- charplot:rows 5))
+(define charplot:width (- charplot:columns 15))
+
+(define (charplot:printn! n char)
+ (cond ((positive? n)
+ (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))))))
+
+(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 <port>)
+(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 <pathname> evl)
+ (if (not (file-exists? <pathname>))
+ (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <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 <collection>) ;; return element generator
+ ;; default behavior
+ (cond ;; see utilities, below, for generators
+ ((vector? <collection>) (collect:vector-gen-elts <collection>))
+ ((list? <collection>) (collect:list-gen-elts <collection>))
+ ((string? <collection>) (collect:string-gen-elts <collection>))
+ (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 <proc> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-elts <collections>))
+ )
+ (let loop ( (counter 0) )
+ (cond
+ ((< counter max+1)
+ (apply <proc> (map (lambda (g) (g)) generators))
+ (loop (collect:add1 counter))
+ )
+ (else 'unspecific) ; done
+ ) )
+) )
+
+(define (collect:do-keys <proc> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-keys <collections>))
+ )
+ (let loop ( (counter 0) )
+ (cond
+ ((< counter max+1)
+ (apply <proc> (map (lambda (g) (g)) generators))
+ (loop (collect:add1 counter))
+ )
+ (else 'unspecific) ; done
+ ) )
+) )
+
+(define (collect:map-elts <proc> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-elts <collections>))
+ (vec (make-vector (yasos:size (car <collections>))))
+ )
+ (let loop ( (index 0) )
+ (cond
+ ((< index max+1)
+ (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
+ (loop (collect:add1 index))
+ )
+ (else vec) ; done
+ ) )
+) )
+
+(define (collect:map-keys <proc> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-keys <collections>))
+ (vec (make-vector (yasos:size (car <collections>))))
+ )
+ (let loop ( (index 0) )
+ (cond
+ ((< index max+1)
+ (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
+ (loop (collect:add1 index))
+ )
+ (else vec) ; done
+ ) )
+) )
+
+(define-operation (collect:for-each-key <collection> <proc>)
+ ;; default
+ (collect:do-keys <proc> <collection>) ;; talk about lazy!
+)
+
+(define-operation (collect:for-each-elt <collection> <proc>)
+ (collect:do-elts <proc> <collection>)
+)
+
+(define (collect:reduce <proc> <seed> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-elts <collections>))
+ )
+ (let loop ( (count 0) )
+ (cond
+ ((< count max+1)
+ (set! <seed>
+ (apply <proc> <seed> (map (lambda (g) (g)) generators)))
+ (loop (collect:add1 count))
+ )
+ (else <seed>)
+ ) )
+) )
+
+
+
+;; pred true for every elt?
+(define (collect:every? <pred?> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-elts <collections>))
+ )
+ (let loop ( (count 0) )
+ (cond
+ ((< count max+1)
+ (if (apply <pred?> (map (lambda (g) (g)) generators))
+ (loop (collect:add1 count))
+ #f)
+ )
+ (else #t)
+ ) )
+) )
+
+;; pred true for any elt?
+(define (collect:any? <pred?> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-elts <collections>))
+ )
+ (let loop ( (count 0) )
+ (cond
+ ((< count max+1)
+ (if (apply <pred?> (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! <list> <index> <value>)
+
+ (define (set-loop last this idx)
+ (cond
+ ((zero? idx)
+ (set-cdr! last (cons <value> (cdr this)))
+ <list>
+ )
+ (else (set-loop (cdr last) (cdr this) (collect:sub1 idx)))
+ ) )
+
+ ;; main
+ (if (zero? <index>)
+ (cons <value> (cdr <list>)) ;; return value
+ (set-loop <list> (cdr <list>) (collect:sub1 <index>)))
+)
+
+(add-setter list-ref collect:list-set!) ; for (setter list-ref)
+
+
+;; generator for list elements
+(define (collect:list-gen-elts <list>)
+ (lambda ()
+ (if (null? <list>)
+ (slib:error "No more list elements in generator")
+ (let ( (elt (car <list>)) )
+ (set! <list> (cdr <list>))
+ elt))
+) )
+
+;; generator for vector elements
+(define (collect:make-vec-gen-elts <accessor>)
+ (lambda (vec)
+ (let ( (max+1 (yasos:size vec))
+ (index 0)
+ )
+ (lambda ()
+ (cond ((< index max+1)
+ (set! index (collect:add1 index))
+ (<accessor> 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 <thunk1> <thunk2> <thunk3>) procedure
+
+;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: 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 <thunk1> <thunk2> <thunk3>)
+ (<thunk1>)
+ (set! dynamic:winds (cons (cons <thunk1> <thunk3>) dynamic:winds))
+ (let ((ans (<thunk2>)))
+ (set! dynamic:winds (cdr dynamic:winds))
+ (<thunk3>)
+ 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 <bevan@cs.man.ac.uk> 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? <string>) already here.
+
+;;; (DELETE-FILE <string>)
+(define (delete-file f) (system (string-append "rm " f)))
+
+;------------
+
+;;; (OUTPUT-PORT-WIDTH <port>)
+(define (output-port-width . arg) 79)
+
+;;; (OUTPUT-PORT-HEIGHT <port>)
+(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 <pathname> evl)
+ (if (not (file-exists? <pathname>))
+ (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <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 (<pathname> . rest)
+ (let ((env (if (null? rest) (list (global-environment)) rest)))
+ (apply primitive-load <pathname> 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 (<pathname> . 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 p<q for all
+; pq=m. Then the recursive call tree forms a geometric progression
+; starting at one, and doubling until reaching sqrt(n)/2, or a length of
+; log2(sqrt(n)/2). From the formula for a geometric progression, there is
+; a total of about 2^log2(sqrt(n)/2) = sqrt(n)/2 calls. Assuming that
+; addition, subtraction, comparison, and multiplication/division by two
+; occur in constant time, this implies O(sqrt(n)/2) time and a
+; O((sqrt(n)/2)*log2(n)) requirement of stack space.
+
+(define (prime:f u v b n)
+ (if (<= n 0)
+ (cond ((negative? n) #f)
+ ((= u 1) #f)
+ ((= v 1) #f)
+ ; Do both of these factors need to be factored?
+ (else (append (or (prime:f 1 1 2 (quotient (- u 1) 2))
+ (list u))
+ (or (prime:f 1 1 2 (quotient (- v 1) 2))
+ (list v)))))
+ (if (even? n)
+ (or (prime:f u v (+ b b) (quotient n 2))
+ (prime:f (+ u b) (+ v b) (+ b b) (quotient (- n (+ u v b)) 2)))
+ (or (prime:f (+ u b) v (+ b b) (quotient (- n v) 2))
+ (prime:f u (+ v b) (+ b b) (quotient (- n u) 2))))))
+
+(define (prime:factor m)
+ (if
+ (negative? m) (cons -1 (prime:factor (- m)))
+ (let* ((s (gcd m prime:product))
+ (r (quotient m s)))
+ (if (even? s)
+ (append
+ (if (= 1 r) '() (prime:factor r))
+ (cons 2 (let ((s/2 (quotient s 2)))
+ (if (= s/2 1) '()
+ (or (prime:f 1 1 2 (quotient (- s/2 1) 2))
+ (list s/2))))))
+ (if (= 1 s) (or (prime:f 1 1 2 (quotient (- m 1) 2)) (list m))
+ (append (if (= 1 r) '()
+ (or (prime:f 1 1 2 (quotient (- r 1) 2)) (list r)))
+ (or (prime:f 1 1 2 (quotient (- s 1) 2)) (list s))))))))
+
+(define jacobi-symbol prime:jacobi-symbol)
+(define prime? prime:prime?)
+(define factor prime:factor)
diff --git a/fluidlet.scm b/fluidlet.scm
new file mode 100644
index 0000000..c93b288
--- /dev/null
+++ b/fluidlet.scm
@@ -0,0 +1,45 @@
+; "fluidlet.scm", FLUID-LET for Scheme
+; Copyright (c) 1992, Dorai Sitaram (dorai@cs.rice.edu)
+;
+;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 'rev4-optional-procedures)
+(require 'common-list-functions)
+(require 'dynamic-wind)
+(require 'macro)
+
+(define list-set! (lambda (s i v) (set-car! (list-tail s i) v)))
+
+(define-syntax fluid-let
+ (syntax-rules ()
+ ((fluid-let ((x v) ...) . body)
+ (let ((%x-names (list 'x ...))
+ (%x-values (list x ...))
+ (%fluid-x-values (list v ...)))
+ (dynamic-wind
+ (lambda ()
+ (set! x (list-ref %fluid-x-values
+ (comlist:position 'x %x-names)))
+ ...)
+ (lambda () . body)
+ (lambda ()
+ (let ((%x-position (comlist:position 'x %x-names)))
+ (list-set! %fluid-x-values %x-position x)
+ (set! x (list-ref %x-values %x-position)))
+ ...))))))
+
+;--- end of file
diff --git a/format.scm b/format.scm
new file mode 100644
index 0000000..1650e72
--- /dev/null
+++ b/format.scm
@@ -0,0 +1,1678 @@
+;;; "format.scm" Common LISP text output formatter for SLIB
+; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
+;
+; This code is in the public domain.
+
+; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer.
+; Please send error reports to the email address above.
+; For documentation see slib.texi and format.doc.
+; For testing load formatst.scm.
+;
+; Version 3.0
+
+(provide 'format)
+(require 'string-case)
+(require 'string-port)
+(require 'rev4-optional-procedures)
+
+;;; Configuration ------------------------------------------------------------
+
+(define format:symbol-case-conv #f)
+;; Symbols are converted by symbol->string 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 <c|3>")
+(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)) "<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 <b> c <d> e <f> 10")
+(test '("~{ ~a ~^<~a>~} ~a" (a b c d e) 10) " a <b> c <d> 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 <port>)
+(define (output-port-width . arg) 79)
+
+;;; (OUTPUT-PORT-HEIGHT <port>)
+(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 <pathname>)
+ (slib:eval-load <pathname> defmacro:eval))
+
+(define (slib:eval-load <pathname> evl)
+ (if (not (file-exists? <pathname>))
+ (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <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 <string>)
+; getenv ;posix (getenv <string>)
+; 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 <port>)
+(define (output-port-width . arg) 79)
+
+;;; (OUTPUT-PORT-HEIGHT <port>)
+(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? <string>)
+(define (file-exists? f) #f)
+
+;;; (DELETE-FILE <string>)
+(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 <pathname>)
+ (slib:eval-load <pathname> defmacro:eval))
+
+(define (slib:eval-load <pathname> evl)
+ (if (not (file-exists? <pathname>))
+ (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <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 <formals>, 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 <pathname>)
+ (slib:eval-load <pathname> 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<?)))
+! (define make-heap
+ (let ((cstr (record-constructor heap-rtd)))
+ (lambda (pred<?)
+ (cstr (make-vector 4) 0 pred<?))))
+! (define heap-ref
+ (let ((ra (record-accessor heap-rtd 'array)))
+ (lambda (a i)
+ (vector-ref (ra a) (+ -1 i)))))
+! (define heap-set!
+ (let ((ra (record-accessor heap-rtd 'array)))
+ (lambda (a i v)
+ (vector-set! (ra a) (+ -1 i) v))))
+! (define heap-exchange
+ (let ((aa (record-accessor heap-rtd 'array)))
+ (lambda (a i j)
+ (set! i (+ -1 i))
+--- 22,53 ----
+ ;;; 1989 MIT Press.
+
+ (require 'record)
++
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++
++ (declare (integrate
++ heap-size
++ heap<?))
++
+ (define heap-rtd (make-record-type "heap" '(array size heap<?)))
+!
+! (define-integrable make-heap
+ (let ((cstr (record-constructor heap-rtd)))
+ (lambda (pred<?)
+ (cstr (make-vector 4) 0 pred<?))))
+!
+! (define-integrable heap-ref
+ (let ((ra (record-accessor heap-rtd 'array)))
+ (lambda (a i)
+ (vector-ref (ra a) (+ -1 i)))))
+!
+! (define-integrable heap-set!
+ (let ((ra (record-accessor heap-rtd 'array)))
+ (lambda (a i v)
+ (vector-set! (ra a) (+ -1 i) v))))
+!
+! (define-integrable heap-exchange
+ (let ((aa (record-accessor heap-rtd 'array)))
+ (lambda (a i j)
+ (set! i (+ -1 i))
+***************
+*** 44,51 ****
+--- 56,66 ----
+ (tmp (vector-ref ra i)))
+ (vector-set! ra i (vector-ref ra j))
+ (vector-set! ra j tmp)))))
++
+ (define heap-size (record-accessor heap-rtd 'size))
++
+ (define heap<? (record-accessor heap-rtd 'heap<?))
++
+ (define heap-set-size
+ (let ((aa (record-accessor heap-rtd 'array))
+ (am (record-modifier heap-rtd 'array))
+***************
+*** 59,68 ****
+ (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 (heapify a i)
+ (define l (heap-left i))
+ (define r (heap-right i))
+--- 74,85 ----
+ (vector-set! nra i (vector-ref ra i)))))
+ (sm a s)))))
+
+! (define-integrable (heap-parent i) (quotient i 2))
+
++ (define-integrable (heap-left i) (* 2 i))
++
++ (define-integrable (heap-right i) (+ 1 (* 2 i)))
++
+ (define (heapify a i)
+ (define l (heap-left i))
+ (define r (heap-right i))
+***************
+*** 99,104 ****
+--- 116,122 ----
+ max))
+
+ (define heap #f)
++
+ (define (heap-test)
+ (set! heap (make-heap char>?))
+ (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 <port>)
+(define output-port-width output-port/x-size)
+
+;;; (OUTPUT-PORT-HEIGHT <port>)
+(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 <pathname> evl)
+ (if (not (file-exists? <pathname>))
+ (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <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 <special>)
+; (macro <rules> <env>)
+; (identifier <id>)
+;
+; and where <special> is one of
+;
+; quote
+; lambda
+; if
+; set!
+; begin
+; define
+; define-syntax
+; let-syntax
+; letrec-syntax
+; syntax-rules
+;
+; and where <rules> is a compiled <transformer spec> (see R4RS),
+; <env> is a syntactic environment, and <id> 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 <formals> and an alist returned by mw:rename-vars that contains
+; a new name for each formal identifier in <formals>, 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 <transformer spec>.
+; 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 <transformer spec>.
+
+;;; The input is a <transformer spec> 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 <transformer spec> and a syntactic environment,
+; returns a macro denotation.
+;
+; A macro denotation is of the form
+;
+; (macro (<rule> ...) env)
+;
+; where each <rule> 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<?)))
+
+;; Constructor.
+(define heap:make-heap
+ (let ((cstr (record-constructor heap:rtd)))
+ (lambda (pred<?)
+ (cstr (make-vector 4) 0 pred<?))))
+
+;; Reference an element.
+(define heap:ref
+ (let ((ra (record-accessor heap:rtd 'array)))
+ (lambda (a i)
+ (vector-ref (ra a) (+ -1 i)))))
+
+;; Set an element.
+(define heap:set!
+ (let ((ra (record-accessor heap:rtd 'array)))
+ (lambda (a i v)
+ (vector-set! (ra a) (+ -1 i) v))))
+
+;; Exchange two elements.
+(define heap:exchange
+ (let ((aa (record-accessor heap:rtd 'array)))
+ (lambda (a i j)
+ (set! i (+ -1 i))
+ (set! j (+ -1 j))
+ (let* ((ra (aa a))
+ (tmp (vector-ref ra i)))
+ (vector-set! ra i (vector-ref ra j))
+ (vector-set! ra j tmp)))))
+
+
+;; Get length.
+(define heap:length (record-accessor heap:rtd 'size))
+
+(define heap:heap<? (record-accessor heap:rtd 'heap<?))
+
+(define heap:set-size!
+ (let ((aa (record-accessor heap:rtd 'array))
+ (am (record-modifier heap:rtd 'array))
+ (sm (record-modifier heap:rtd 'size)))
+ (lambda (a s)
+ (let ((ra (aa a)))
+ (if (> 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<? a) (heap:ref a i) (heap:ref a l)))
+ l
+ i)))
+ (cond ((and (<= r (heap:length a))
+ ((heap:heap<? a) (heap:ref a largest) (heap:ref a r)))
+ (set! largest r)))
+ (cond ((not (= largest i))
+ (heap:exchange a i largest)
+ (heap:heapify a largest)))))
+
+(define (heap:insert! a key)
+ (define i (+ 1 (heap:length a)))
+ (heap:set-size! a i)
+ (do ()
+ ((not (and (> i 1)
+ ((heap:heap<? a) (heap:ref a (heap:parent i)) key))))
+ (heap:set! a i (heap:ref a (heap:parent i)))
+ (set! i (heap:parent i)))
+ (heap:set! a i key))
+
+(define (heap:extract-max! a)
+ (if (< (heap:length a) 1)
+ (slib:error "heap underflow" a))
+ (let ((max (heap:ref a 1)))
+ (heap:set! a 1 (heap:ref a (heap:length a)))
+ (heap:set-size! a (+ -1 (heap:length a)))
+ (heap:heapify a 1)
+ max))
+
+;;
+;; Externals.
+;;
+(define make-heap heap:make-heap)
+(define heap-insert! heap:insert!)
+(define heap-extract-max! heap:extract-max!)
+(define heap-length heap:length)
+
+(define (heap:test)
+ (require 'debug)
+ (let ((heap #f))
+ (set! heap (make-heap char>?))
+ (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 <expression>) to
+;;; (MAKE-PROMISE (LAMBDA () <expression>))
+;;; 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 (<pathname>)
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <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 <pathname>) <pathname>)
+
+(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 (<pathname> . extra)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <pathname>)
+ (apply *old-load* (cons <pathname> extra))
+ (require:provide <pathname>)
+ (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 <=? <=)
+(define =? =)
+(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 <hanche@imf.unit.no>
+
+;;; 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 <hanche@imf.unit.no>
+
+;;; 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 <pathname>)
+ (slib:eval-load <pathname> 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 (char<? (car scanset) fc)
+ (not (eqv? #\] fc)))
+ (set! fc (char->integer 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:
+
+; <expression> :== <application>
+; | <variable>
+; | (set! <variable> <expression>)
+; | (define <variable> <expression>)
+; | (lambda (<variable>*) <expression>)
+; | (lambda <variable> <expression>)
+; | (lambda (<variable>+ . <variable>) <expression>)
+; | (letrec (<binding>+) <expression>)
+; | (if <expression> <expression> <expression>)
+; | (begin <expression> <expression>)
+; | (quote <datum>)
+; <application> :== (<expression>+)
+; <binding> :== (<variable> <expression>)
+; <variable> :== <symbol>
+
+; 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 <port>)
+(define (output-port-width . arg) 79)
+
+;;; (OUTPUT-PORT-HEIGHT <port>)
+(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? <string>)
+(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 <string>)
+(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 <pathname> evl)
+ (if (not (file-exists? <pathname>))
+ (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <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 <port>)
+(define (output-port-width . arg) 79)
+
+;;; (OUTPUT-PORT-HEIGHT <port>)
+(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? <string>)
+(define (file-exists? f) #f)
+
+;;; (DELETE-FILE <string>)
+(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 <pathname>)
+ (slib:eval-load <pathname> defmacro:eval))
+
+(define (slib:eval-load <pathname> evl)
+ (if (not (file-exists? <pathname>))
+ (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <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 <pathname>)
+ (slib:eval-load <pathname> 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
+<eigenstr@CS.Rose-Hulman.Edu> (who thanks Dave Love <D.Love@dl.ac.uk>)
+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 "#<SIMPLE-TABLE>"))
+ ((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 <string of blanks>) => ""
+ (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<? STRING1 STRING2
+ Returns #t if the first non-matching run of alphabetic upper-case
+ or the first non-matching run of alphabetic lower-case or the first
+ non-matching run of numeric characters of STRING1 is `string<?'
+ than the corresponding non-matching run of characters of STRING2.
+
+ (chap:string<? "a.9" "a.10") => #t
+ (chap:string<? "4c" "4aa") => #t
+ (chap:string<? "Revised^{3.99}" "Revised^{4}") => #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<?' than the result.
+
+ (chap:next-string "a.9") => "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:
+ <inverter>::(<number> <description>)
+ Generic-methods
+ <inverter>::value => <number>::value
+ <inverter>::set-value! => <number>::set-value!
+ <inverter>::describe => <description>::describe
+ <inverter>::help
+ <inverter>::invert
+ <inverter>::inverter?
+
+Number Documention
+..................
+
+ Inheritance
+ <number>::()
+ Slots
+ <number>::<x>
+ Generic Methods
+ <number>::value
+ <number>::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 <value> (get-method self value))
+ (make-method! self invert (lambda (self) (/ 1 (<value> 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<?
+ Returns a binary heap suitable which can be used for priority queue
+ operations.
+
+ - Function: heap-length HEAP
+ Returns the number of elements in HEAP.
+
+ - Procedure: heap-insert! HEAP ITEM
+ Inserts ITEM into HEAP. ITEM can be inserted multiple times. The
+ value returned is unspecified.
+
+ - Function: heap-extract-max! HEAP
+ Returns the item which is larger than all others according to the
+ PRED<? argument to `make-heap'. If there are no items in HEAP, an
+ error is signaled.
+
+ The algorithm for priority queues was taken from `Introduction to
+Algorithms' by T. Cormen, C. Leiserson, R. Rivest. 1989 MIT Press.
+
+
+File: slib.info, Node: Queues, Next: Records, Prev: Priority Queues, Up: Data Structures
+
+Queues
+======
+
+ `(require 'queue)'
+
+ A "queue" is a list where elements can be added to both the front and
+rear, and removed from the front (i.e., they are what are often called
+"dequeues"). A queue may also be used like a stack.
+
+ - Function: make-queue
+ Returns a new, empty queue.
+
+ - Function: queue? OBJ
+ Returns `#t' if OBJ is a queue.
+
+ - Function: queue-empty? Q
+ Returns `#t' if the queue Q is empty.
+
+ - Procedure: queue-push! Q DATUM
+ Adds DATUM to the front of queue Q.
+
+ - Procedure: enquque! Q DATUM
+ Adds DATUM to the rear of queue Q.
+
+ All of the following functions raise an error if the queue Q is empty.
+
+ - Function: queue-front Q
+ Returns the datum at the front of the queue Q.
+
+ - Function: queue-rear Q
+ Returns the datum at the rear of the queue Q.
+
+ - Prcoedure: queue-pop! Q
+ - Procedure: dequeue! Q
+ Both of these procedures remove and return the datum at the front
+ of the queue. `queue-pop!' is used to suggest that the queue is
+ being used like a stack.
+
diff --git a/slib.info-2 b/slib.info-2
new file mode 100644
index 0000000..f1c31c5
--- /dev/null
+++ b/slib.info-2
@@ -0,0 +1,1193 @@
+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: Records, Next: Base Table, Prev: Queues, Up: Data Structures
+
+Records
+=======
+
+ `(require 'record)'
+
+ The Record package provides a facility for user to define their own
+record data types.
+
+ - Function: make-record-type TYPE-NAME FIELD-NAMES
+ Returns a "record-type descriptor", a value representing a new data
+ type disjoint from all others. The TYPE-NAME argument must be a
+ string, but is only used for debugging purposes (such as the
+ printed representation of a record of the new type). The
+ FIELD-NAMES argument is a list of symbols naming the "fields" of a
+ record of the new type. It is an error if the list contains any
+ duplicates. It is unspecified how record-type descriptors are
+ represented.
+
+ - Function: record-constructor RTD [FIELD-NAMES]
+ Returns a procedure for constructing new members of the type
+ represented by RTD. The returned procedure accepts exactly as
+ many arguments as there are symbols in the given list,
+ FIELD-NAMES; these are used, in order, as the initial values of
+ those fields in a new record, which is returned by the constructor
+ procedure. The values of any fields not named in that list are
+ unspecified. The FIELD-NAMES argument defaults to the list of
+ field names in the call to `make-record-type' that created the
+ type represented by RTD; if the FIELD-NAMES argument is provided,
+ it is an error if it contains any duplicates or any symbols not in
+ the default list.
+
+ - Function: record-predicate RTD
+ Returns a procedure for testing membership in the type represented
+ by RTD. The returned procedure accepts exactly one argument and
+ returns a true value if the argument is a member of the indicated
+ record type; it returns a false value otherwise.
+
+ - Function: record-accessor RTD FIELD-NAME
+ Returns a procedure for reading the value of a particular field of
+ a member of the type represented by RTD. The returned procedure
+ accepts exactly one argument which must be a record of the
+ appropriate type; it returns the current value of the field named
+ by the symbol FIELD-NAME in that record. The symbol FIELD-NAME
+ must be a member of the list of field-names in the call to
+ `make-record-type' that created the type represented by RTD.
+
+ - Function: record-modifier RTD FIELD-NAME
+ Returns a procedure for writing the value of a particular field of
+ a member of the type represented by RTD. The returned procedure
+ accepts exactly two arguments: first, a record of the appropriate
+ type, and second, an arbitrary Scheme value; it modifies the field
+ named by the symbol FIELD-NAME in that record to contain the given
+ value. The returned value of the modifier procedure is
+ unspecified. The symbol FIELD-NAME must be a member of the list
+ of field-names in the call to `make-record-type' that created the
+ type represented by RTD.
+
+ - Function: record? OBJ
+ Returns a true value if OBJ is a record of any type and a false
+ value otherwise. Note that `record?' may be true of any Scheme
+ value; of course, if it returns true for some particular value,
+ then `record-type-descriptor' is applicable to that value and
+ returns an appropriate descriptor.
+
+ - Function: record-type-descriptor RECORD
+ Returns a record-type descriptor representing the type of the given
+ record. That is, for example, if the returned descriptor were
+ passed to `record-predicate', the resulting predicate would return
+ a true value when passed the given record. Note that it is not
+ necessarily the case that the returned descriptor is the one that
+ was passed to `record-constructor' in the call that created the
+ constructor procedure that created the given record.
+
+ - Function: record-type-name RTD
+ Returns the type-name associated with the type represented by rtd.
+ The returned value is `eqv?' to the TYPE-NAME argument given in
+ the call to `make-record-type' that created the type represented by
+ RTD.
+
+ - Function: record-type-field-names RTD
+ Returns a list of the symbols naming the fields in members of the
+ type represented by RTD. The returned value is `equal?' to the
+ field-names argument given in the call to `make-record-type' that
+ created the type represented by RTD.
+
+
+File: slib.info, Node: Base Table, Next: Relational Database, Prev: Records, Up: Data Structures
+
+Base Table
+==========
+
+ A base table implementation using Scheme association lists is
+available as the value of the identifier `alist-table' after doing:
+
+ (require 'alist-table)
+
+ Association list base tables are suitable for small databases and
+support all Scheme types when temporary and readable/writeable Scheme
+types when saved. I hope support for other base table implementations
+will be added in the future.
+
+ This rest of this section documents the interface for a base table
+implementation from which the *Note Relational Database:: package
+constructs a Relational system. It will be of interest primarily to
+those wishing to port or write new base-table implementations.
+
+ All of these functions are accessed through a single procedure by
+calling that procedure with the symbol name of the operation. A
+procedure will be returned if that operation is supported and `#f'
+otherwise. For example:
+
+ (require 'alist-table)
+ (define open-base (alist-table 'make-base))
+ make-base => *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 [<length>]
+ number [<base>]
+ money <currency>
+ date-time
+ boolean
+
+ foreign-key <table-name>
+ expression
+ virtual <expression>
+
+
+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:
+
+ (<name> <descriptor-name> <descriptor-name> <rows>)
+ or
+ (<name> <primary-key-fields> <other-fields> <rows>)
+
+ where <name> is the table name, <descriptor-name> is the symbol
+ name of a descriptor table, <primary-key-fields> and
+ <other-fields> describe the primary keys and other fields
+ respectively, and <rows> is a list of data rows to be added to the
+ table.
+
+ <primary-key-fields> and <other-fields> are lists of field
+ descriptors of the form:
+
+ (<column-name> <domain>)
+ or
+ (<column-name> <domain> <column-integrity-rule>)
+
+ where <column-name> is the column name, <domain> is the domain of
+ the column, and <column-integrity-rule> is an expression whose
+ value is a procedure of one argument (and returns non-`#f' to
+ signal an error).
+
+ If <domain> 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<?
+ This procedure creates and returns a new tree type based on the
+ ordering predicate KEY<?. KEY<? must be a total ordering, having
+ the property that for all key values `a', `b' and `c':
+
+ (key<? a a) => #f
+ (and (key<? a b) (key<? b a)) => #f
+ (if (and (key<? a b) (key<? b c))
+ (key<? a c)
+ #t) => #t
+
+ Two key values are assumed to be equal if neither is less than the
+ other by KEY<?.
+
+ Each call to `make-wt-tree-type' returns a distinct value, and
+ trees are only compatible if their tree types are `eq?'. A
+ consequence is that trees that are intended to be used in binary
+ tree operations must all be created with a tree type originating
+ from the same call to `make-wt-tree-type'.
+
+ - variable+: number-wt-type
+ A standard tree type for trees with numeric keys. `Number-wt-type'
+ could have been defined by
+
+ (define number-wt-type (make-wt-tree-type <))
+
+ - variable+: string-wt-type
+ A standard tree type for trees with string keys. `String-wt-type'
+ could have been defined by
+
+ (define string-wt-type (make-wt-tree-type string<?))
+
+ - procedure+: make-wt-tree WT-TREE-TYPE
+ This procedure creates and returns a newly allocated weight
+ balanced tree. The tree is empty, i.e. it contains no
+ associations. WT-TREE-TYPE is a weight balanced tree type
+ obtained by calling `make-wt-tree-type'; the returned tree has
+ this type.
+
+ - procedure+: singleton-wt-tree WT-TREE-TYPE KEY DATUM
+ This procedure creates and returns a newly allocated weight
+ balanced tree. The tree contains a single association, that of
+ DATUM with KEY. WT-TREE-TYPE is a weight balanced tree type
+ obtained by calling `make-wt-tree-type'; the returned tree has
+ this type.
+
+ - procedure+: alist->wt-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 <mafm@cs.uwa.edu.au> 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))
+ => #<unspecified>
+ (define foo (make-term 'plus 1 2))
+ => foo
+ (term-left foo)
+ => 1
+ (set-term-left! foo 2345)
+ => #<unspecified>
+ (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
+<hanche@imf.unit.no> 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 `#<INSTANCE>' 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) "#<instance>" "~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 "#<Cell: ~s>" (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 "#<Array ~s>" (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 "#<Cell-with-history ~s>" (fetch self))))))
+
+ (define-access-operation fetch)
+ (add-setter fetch store!)
+ (define foo (make-cell 1))
+ (print foo #f)
+ => "#<Cell: 1>"
+ (set (fetch foo) 2)
+ =>
+ (print foo #f)
+ => "#<Cell: 2>"
+ (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 <stdio.h>"
+ "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 <stdio.h>'>>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)
+ => (#<unspecified> #<unspecified> #<unspecified>)
+ (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.
+
+`~'<newline>
+ Continuation Line.
+ `~:'<newline>
+ newline is ignored, white space left.
+
+ `~@'<newline>
+ 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>?', `char-ci<?',
+`char-ci>?', `string<?', `string>?', `string-ci<?', and `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: <=?
+ - Function: =?
+ - 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.
+* >=?: 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.
+* 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
+<eigenstr@@CS.Rose-Hulman.Edu> (who thanks Dave Love <D.Love@@dl.ac.uk>)
+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 "#<SIMPLE-TABLE>"))
+ ((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 <string of blanks>) @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
+Returns #t if the first non-matching run of alphabetic upper-case or the
+first non-matching run of alphabetic lower-case or the first
+non-matching run of numeric characters of @var{string1} is
+@code{string<?} than the corresponding non-matching run of characters of
+@var{string2}.
+
+@example
+(chap:string<? "a.9" "a.10") @result{} #t
+(chap:string<? "4c" "4aa") @result{} #t
+(chap:string<? "Revised^@{3.99@}" "Revised^@{4@}") @result{} #t
+@end example
+
+@defunx 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<?} than the result.
+
+@example
+(chap:next-string "a.9") @result{} "a.10"
+(chap:next-string "4c") @result{} "4d"
+(chap:next-string "4z") @result{} "4aa"
+(chap:next-string "Revised^@{4@}") @result{} "Revised^@{5@}"
+
+@end example
+@end defun
+
+@node Object, Parameter lists, Chapter Ordering, Data Structures
+@section Macroless Object System
+
+@code{(require 'object)}
+
+This is the Macroless Object System written by Wade Humeniuk
+(whumeniu@@datap.ca). Conceptual Tributes: @ref{Yasos}, MacScheme's
+%object, CLOS, Lack of R4RS macros.
+
+@subsection Concepts
+@table @asis
+
+@item OBJECT
+An object is an ordered association-list (by @code{eq?}) of methods
+(procedures). Methods can be added (@code{make-method!}), deleted
+(@code{unmake-method!}) and retrieved (@code{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.
+
+@item GENERIC-METHOD
+A generic-method associates (in terms of @code{eq?}) object's method.
+This allows scheme function style to be used for objects. The calling
+scheme for using a generic method is @code{(generic-method object param1
+param2 ...)}.
+
+@item 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?
+
+@item GENERIC-PREDICATE
+A generic method that returns a boolean value for any scheme obj.
+
+@item PREDICATE
+A object's method asscociated with a generic-predicate. Returns
+@code{#t}.
+@end table
+
+@subsection Procedures
+
+@defun make-object ancestor @dots{}
+Returns an object. Current object implementation is a tagged vector.
+@var{ancestor}s are optional and must be objects in terms of object?.
+@var{ancestor}s methods are included in the object. Multiple
+@var{ancestor}s might associate the same generic-method with a method.
+In this case the method of the @var{ancestor} first appearing in the
+list is the one returned by @code{get-method}.
+@end defun
+
+@defun object? obj
+Returns boolean value whether @var{obj} was created by make-object.
+@end defun
+
+@defun make-generic-method exception-procedure
+Returns a procedure which be associated with an object's methods. If
+@var{exception-procedure} is specified then it is used to process
+non-objects.
+@end defun
+
+@defun make-generic-predicate
+Returns a boolean procedure for any scheme object.
+@end defun
+
+@defun make-method! object generic-method method
+Associates @var{method} to the @var{generic-method} in the object. The
+@var{method} overrides any previous association with the
+@var{generic-method} within the object. Using @code{unmake-method!}
+will restore the object's previous association with the
+@var{generic-method}. @var{method} must be a procedure.
+@end defun
+
+@defun make-predicate! object generic-preciate
+Makes a predicate method associated with the @var{generic-predicate}.
+@end defun
+
+@defun unmake-method! object generic-method
+Removes an object's association with a @var{generic-method} .
+@end defun
+
+@defun get-method object generic-method
+Returns the object's method associated (if any) with the
+@var{generic-method}. If no associated method exists an error is
+flagged.
+@end defun
+
+@subsection Examples
+
+@example
+(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)
+@end example
+
+@subsubsection Inverter Documentation
+Inheritance:
+@lisp
+ <inverter>::(<number> <description>)
+@end lisp
+Generic-methods
+@lisp
+ <inverter>::value @result{} <number>::value
+ <inverter>::set-value! @result{} <number>::set-value!
+ <inverter>::describe @result{} <description>::describe
+ <inverter>::help
+ <inverter>::invert
+ <inverter>::inverter?
+@end lisp
+
+@subsubsection Number Documention
+Inheritance
+@lisp
+ <number>::()
+@end lisp
+Slots
+@lisp
+ <number>::<x>
+@end lisp
+Generic Methods
+@lisp
+ <number>::value
+ <number>::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 <value> (get-method self value))
+ (make-method! self invert (lambda (self) (/ 1 (<value> 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 pred<?
+Returns a binary heap suitable which can be used for priority queue
+operations.
+@end defun
+
+@defun heap-length heap
+Returns the number of elements in @var{heap}.@refill
+@end defun
+
+@deffn Procedure heap-insert! heap item
+Inserts @var{item} into @var{heap}. @var{item} can be inserted multiple
+times. The value returned is unspecified.@refill
+@end deffn
+
+@defun heap-extract-max! heap
+Returns the item which is larger than all others according to the
+@var{pred<?} argument to @code{make-heap}. If there are no items in
+@var{heap}, an error is signaled.@refill
+@end defun
+
+The algorithm for priority queues was taken from @cite{Introduction to
+Algorithms} by T. Cormen, C. Leiserson, R. Rivest. 1989 MIT Press.
+
+
+
+@node Queues, Records, Priority Queues, Data Structures
+@section Queues
+
+@code{(require 'queue)}
+
+A @dfn{queue} is a list where elements can be added to both the front
+and rear, and removed from the front (i.e., they are what are often
+called @dfn{dequeues}). A queue may also be used like a stack.@refill
+
+@defun make-queue
+Returns a new, empty queue.
+@end defun
+
+@defun queue? obj
+Returns @code{#t} if @var{obj} is a queue.
+@end defun
+
+@defun queue-empty? q
+Returns @code{#t} if the queue @var{q} is empty.
+@end defun
+
+@deffn Procedure queue-push! q datum
+Adds @var{datum} to the front of queue @var{q}.
+@end deffn
+
+@deffn Procedure enquque! q datum
+Adds @var{datum} to the rear of queue @var{q}.
+@end deffn
+
+All of the following functions raise an error if the queue @var{q} is
+empty.@refill
+
+@defun queue-front q
+Returns the datum at the front of the queue @var{q}.
+@end defun
+
+@defun queue-rear q
+Returns the datum at the rear of the queue @var{q}.
+@end defun
+
+@deffn Prcoedure queue-pop! q
+@deffnx Procedure dequeue! q
+Both of these procedures remove and return the datum at the front of the
+queue. @code{queue-pop!} is used to suggest that the queue is being
+used like a stack.@refill
+@end deffn
+
+
+
+
+
+@node Records, Base Table, Queues, Data Structures
+@section Records
+
+@code{(require 'record)}
+
+The Record package provides a facility for user to define their own
+record data types.
+
+@defun make-record-type type-name field-names
+Returns a @dfn{record-type descriptor}, a value representing a new data
+type disjoint from all others. The @var{type-name} argument must be a
+string, but is only used for debugging purposes (such as the printed
+representation of a record of the new type). The @var{field-names}
+argument is a list of symbols naming the @dfn{fields} of a record of the
+new type. It is an error if the list contains any duplicates. It is
+unspecified how record-type descriptors are represented.@refill
+@end defun
+
+@c @defun make-record-sub-type type-name field-names rtd
+@c Returns a @dfn{record-type descriptor}, a value representing a new data
+@c type, disjoint from all others. The @var{type-name} argument must be a
+@c string. The @var{field-names} argument is a list of symbols naming the
+@c additional @dfn{fields} to be appended to @var{field-names} of
+@c @var{rtd}. It is an error if the combinded list contains any
+@c duplicates.@refill
+@c
+@c Record-modifiers and record-accessors for @var{rtd} work for the new
+@c record-sub-type as well. But record-modifiers and record-accessors for
+@c the new record-sub-type will not neccessarily work for @var{rtd}.@refill
+@c @end defun
+
+@defun record-constructor rtd [field-names]
+Returns a procedure for constructing new members of the type represented
+by @var{rtd}. The returned procedure accepts exactly as many arguments
+as there are symbols in the given list, @var{field-names}; these are
+used, in order, as the initial values of those fields in a new record,
+which is returned by the constructor procedure. The values of any
+fields not named in that list are unspecified. The @var{field-names}
+argument defaults to the list of field names in the call to
+@code{make-record-type} that created the type represented by @var{rtd};
+if the @var{field-names} argument is provided, it is an error if it
+contains any duplicates or any symbols not in the default list.@refill
+@end defun
+
+@defun record-predicate rtd
+Returns a procedure for testing membership in the type represented by
+@var{rtd}. The returned procedure accepts exactly one argument and
+returns a true value if the argument is a member of the indicated record
+type; it returns a false value otherwise.@refill
+@end defun
+
+@c @defun record-sub-predicate rtd
+@c Returns a procedure for testing membership in the type represented by
+@c @var{rtd} or its parents. The returned procedure accepts exactly one
+@c argument and returns a true value if the argument is a member of the
+@c indicated record type or its parents; it returns a false value
+@c otherwise.@refill
+@c @end defun
+
+@defun record-accessor rtd field-name
+Returns a procedure for reading the value of a particular field of a
+member of the type represented by @var{rtd}. The returned procedure
+accepts exactly one argument which must be a record of the appropriate
+type; it returns the current value of the field named by the symbol
+@var{field-name} in that record. The symbol @var{field-name} must be a
+member of the list of field-names in the call to @code{make-record-type}
+that created the type represented by @var{rtd}.@refill
+@end defun
+
+
+@defun record-modifier rtd field-name
+Returns a procedure for writing the value of a particular field of a
+member of the type represented by @var{rtd}. The returned procedure
+accepts exactly two arguments: first, a record of the appropriate type,
+and second, an arbitrary Scheme value; it modifies the field named by
+the symbol @var{field-name} in that record to contain the given value.
+The returned value of the modifier procedure is unspecified. The symbol
+@var{field-name} must be a member of the list of field-names in the call
+to @code{make-record-type} that created the type represented by
+@var{rtd}.@refill
+@end defun
+
+@defun record? obj
+Returns a true value if @var{obj} is a record of any type and a false
+value otherwise. Note that @code{record?} may be true of any Scheme
+value; of course, if it returns true for some particular value, then
+@code{record-type-descriptor} is applicable to that value and returns an
+appropriate descriptor.@refill
+@end defun
+
+@defun record-type-descriptor record
+Returns a record-type descriptor representing the type of the given
+record. That is, for example, if the returned descriptor were passed to
+@code{record-predicate}, the resulting predicate would return a true
+value when passed the given record. Note that it is not necessarily the
+case that the returned descriptor is the one that was passed to
+@code{record-constructor} in the call that created the constructor
+procedure that created the given record.@refill
+@end defun
+
+@defun record-type-name rtd
+Returns the type-name associated with the type represented by rtd. The
+returned value is @code{eqv?} to the @var{type-name} argument given in
+the call to @code{make-record-type} that created the type represented by
+@var{rtd}.@refill
+@end defun
+
+@defun record-type-field-names rtd
+Returns a list of the symbols naming the fields in members of the type
+represented by @var{rtd}. The returned value is @code{equal?} to the
+field-names argument given in the call to @code{make-record-type} that
+created the type represented by @var{rtd}.@refill
+@end defun
+
+
+
+@node Base Table, Relational Database, Records, Data Structures
+@section Base Table
+
+A base table implementation using Scheme association lists is available
+as the value of the identifier @code{alist-table} after doing:
+
+@example
+(require 'alist-table)
+@end example
+
+
+Association list base tables are suitable for small databases and
+support all Scheme types when temporary and readable/writeable Scheme
+types when saved. I hope support for other base table implementations
+will be added in the future.
+
+This rest of this section documents the interface for a base table
+implementation from which the @ref{Relational Database} package
+constructs a Relational system. It will be of interest primarily to
+those wishing to port or write new base-table implementations.
+
+All of these functions are accessed through a single procedure by
+calling that procedure with the symbol name of the operation. A
+procedure will be returned if that operation is supported and @code{#f}
+otherwise. For example:
+
+@example
+@group
+(require 'alist-table)
+(define open-base (alist-table 'make-base))
+make-base @result{} *a procedure*
+(define foo (alist-table 'foo))
+foo @result{} #f
+@end group
+@end example
+
+@defun make-base filename key-dimension column-types
+Returns a new, open, low-level database (collection of tables)
+associated with @var{filename}. This returned database has an empty
+table associated with @var{catalog-id}. The positive integer
+@var{key-dimension} is the number of keys composed to make a
+@var{primary-key} for the catalog table. The list of symbols
+@var{column-types} describes the types of each column for that table.
+If the database cannot be created as specified, @code{#f} is returned.
+
+Calling the @code{close-base} 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 base table implelentation.
+@end defun
+
+@defun open-base filename mutable
+Returns an open low-level 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. If the database
+cannot be opened as specified @code{#f} is returned.
+
+Calling the @code{close-base} (and possibly other) method on a
+@var{mutable?} database will cause @var{filename} to be written to.
+@end defun
+
+@defun write-base lldb filename
+Causes the low-level database @var{lldb} to be written to
+@var{filename}. If the write is successful, also causes @var{lldb} to
+henceforth be associated with @var{filename}. Calling the
+@code{close-database} (and possibly other) method on @var{lldb} may
+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 sync-base lldb
+Causes the file associated with the low-level database @var{lldb} to be
+updated to reflect its current state. If the associated filename is
+@code{#f}, no action is taken and @code{#f} is returned. If this
+operation completes successfully, @code{#t} is returned. Otherwise,
+@code{#f} is returned.
+@end defun
+
+@defun close-base lldb
+Causes the low-level database @var{lldb} to be written to its associated
+file (if any). If the write is successful, subsequent operations to
+@var{lldb} will signal an error. If the operations complete
+successfully, @code{#t} is returned. Otherwise, @code{#f} is returned.
+@end defun
+
+@defun make-table lldb key-dimension column-types
+Returns the @var{base-id} for a new base table, otherwise returns
+@code{#f}. The base table can then be opened using @code{(open-table
+@var{lldb} @var{base-id})}. The positive integer @var{key-dimension} is
+the number of keys composed to make a @var{primary-key} for this table.
+The list of symbols @var{column-types} describes the types of each
+column.
+@end defun
+
+@defvr Constant catalog-id
+A constant @var{base-id} suitable for passing as a parameter to
+@code{open-table}. @var{catalog-id} will be used as the base table for
+the system catalog.
+@end defvr
+
+@defun open-table lldb base-id key-dimension column-types
+Returns a @var{handle} for an existing base table in the low-level
+database @var{lldb} if that table exists and can be opened in the mode
+indicated by @var{mutable?}, otherwise returns @code{#f}.
+
+As with @code{make-table}, the positive integer @var{key-dimension} is
+the number of keys composed to make a @var{primary-key} for this table.
+The list of symbols @var{column-types} describes the types of each
+column.
+@end defun
+
+@defun kill-table lldb base-id key-dimension column-types
+Returns @code{#t} if the base table associated with @var{base-id} was
+removed from the low level database @var{lldb}, and @code{#f} otherwise.
+@end defun
+
+@defun make-keyifier-1 type
+Returns a procedure which accepts a single argument which must be of
+type @var{type}. This returned procedure returns an object suitable for
+being a @var{key} argument in the functions whose descriptions follow.
+
+Any 2 arguments of the supported type passed to the returned function
+which are not @code{equal?} must result in returned values which are not
+@code{equal?}.
+@end defun
+
+@defun make-list-keyifier key-dimension types
+The list of symbols @var{types} must have at least @var{key-dimension}
+elements. Returns a procedure which accepts a list of length
+@var{key-dimension} and whose types must corresopond to the types named
+by @var{types}. This returned procedure combines the elements of its
+list argument into an object suitable for being a @var{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
+@code{equal?} must result in returned values which are not
+@code{equal?}.
+@end defun
+
+@defun make-key-extractor key-dimension types column-number
+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 @var{key} which is @code{equal?} to the
+@var{column-number}th element of the list which was passed to create
+@var{combined-key}. The list @var{types} must have at least
+@var{key-dimension} elements.
+@end defun
+
+@defun make-key->list 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 [<length>]
+ number [<base>]
+ money <currency>
+ date-time
+ boolean
+
+ foreign-key <table-name>
+ expression
+ virtual <expression>
+@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{<name>} @r{<descriptor-name>} @r{<descriptor-name>} @r{<rows>})
+@end lisp
+or
+@lisp
+(@r{<name>} @r{<primary-key-fields>} @r{<other-fields>} @r{<rows>})
+@end lisp
+
+where @r{<name>} is the table name, @r{<descriptor-name>} is the symbol
+name of a descriptor table, @r{<primary-key-fields>} and
+@r{<other-fields>} describe the primary keys and other fields
+respectively, and @r{<rows>} is a list of data rows to be added to the
+table.
+
+@r{<primary-key-fields>} and @r{<other-fields>} are lists of field
+descriptors of the form:
+
+@lisp
+(@r{<column-name>} @r{<domain>})
+@end lisp
+or
+@lisp
+(@r{<column-name>} @r{<domain>} @r{<column-integrity-rule>})
+@end lisp
+
+where @r{<column-name>} is the column name, @r{<domain>} is the domain
+of the column, and @r{<column-integrity-rule>} is an expression whose
+value is a procedure of one argument (and returns non-@code{#f} to
+signal an error).
+
+If @r{<domain>} 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 key<?
+This procedure creates and returns a new tree type based on the ordering
+predicate @var{key<?}.
+@var{Key<?} must be a total ordering, having the property that for all
+key values @code{a}, @code{b} and @code{c}:
+
+@example
+(key<? a a) @result{} #f
+(and (key<? a b) (key<? b a)) @result{} #f
+(if (and (key<? a b) (key<? b c))
+ (key<? a c)
+ #t) @result{} #t
+@end example
+
+@noindent
+Two key values are assumed to be equal if neither is less than the other
+by @var{key<?}.
+
+Each call to @code{make-wt-tree-type} returns a distinct value, and
+trees are only compatible if their tree types are @code{eq?}.
+A consequence is
+that trees that are intended to be used in binary tree operations must all be
+created with a tree type originating from the same call to
+@code{make-wt-tree-type}.
+@end deffn
+
+@defvr {variable+} number-wt-type
+A standard tree type for trees with numeric keys. @code{Number-wt-type}
+could have been defined by
+
+@example
+(define number-wt-type (make-wt-tree-type <))
+@end example
+@end defvr
+
+@defvr {variable+} string-wt-type
+A standard tree type for trees with string keys. @code{String-wt-type}
+could have been defined by
+
+@example
+(define string-wt-type (make-wt-tree-type string<?))
+@end example
+@end defvr
+
+
+
+@deffn {procedure+} make-wt-tree wt-tree-type
+This procedure creates and returns a newly allocated weight balanced
+tree. The tree is empty, i.e. it contains no associations.
+@var{Wt-tree-type} is a weight balanced tree type obtained by calling
+@code{make-wt-tree-type}; the returned tree has this type.
+@end deffn
+
+@deffn {procedure+} singleton-wt-tree wt-tree-type key datum
+This procedure creates and returns a newly allocated weight balanced
+tree. The tree contains a single association, that of @var{datum} with
+@var{key}. @var{Wt-tree-type} is a weight balanced tree type obtained
+by calling @code{make-wt-tree-type}; the returned tree has this type.
+@end deffn
+
+@deffn {procedure+} alist->wt-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 <mafm@@cs.uwa.edu.au> 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{} #<unspecified>
+(define foo (make-term 'plus 1 2))
+@result{} foo
+(term-left foo)
+@result{} 1
+(set-term-left! foo 2345)
+@result{} #<unspecified>
+(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
+<hanche@@imf.unit.no> 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
+<A HREF="ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/swob.txt">
+@end ifset
+Scheming with Objects
+@ifset html
+</A>
+@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{#<INSTANCE>} 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) "#<instance>" "~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 "#<Cell: ~s>" (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 "#<Array ~s>" (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 "#<Cell-with-history ~s>" (fetch self))))))
+
+(define-access-operation fetch)
+(add-setter fetch store!)
+(define foo (make-cell 1))
+(print foo #f)
+@result{} "#<Cell: 1>"
+(set (fetch foo) 2)
+@result{}
+(print foo #f)
+@result{} "#<Cell: 2>"
+(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 <stdio.h>"
+ "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 <stdio.h>'>>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{} (#<unspecified> #<unspecified> #<unspecified>)
+(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{~}<newline>
+Continuation Line.
+@table @asis
+@item @code{~:}<newline>
+newline is ignored, white space left.
+@item @code{~@@}<newline>
+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>?},
+@code{char-ci<?}, @code{char-ci>?}, @code{string<?}, @code{string>?},
+@code{string-ci<?}, and @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 <=?
+@defunx =?
+@defunx >?
+@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 <input-port> . 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 <input-port>)))
+ (if (eof-object? c) #f c)))))
+ (next-char (lambda () (read-char <input-port>)
+ (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 <leavens@cs.iastate.edu>
+;;; 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 <init>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 <port>)
+(define output-port-width
+ (lambda x
+ (if (null? x) (line-length (standard-input))
+ (line-length (car x)))))
+
+;;; (OUTPUT-PORT-HEIGHT <port>)
+(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 <pathname>)
+ (slib:eval-load <pathname> defmacro:eval))
+
+(define (slib:eval-load <pathname> evl)
+ (if (not (file-exists? <pathname>))
+ (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <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 <n
+ (cond ((= (string-length a) n) (< n (string-length b)))
+ ;;now (< n (string-length a))
+ ((= (string-length b) n) '#f)
+ ;;now (< n (string-length a))
+ ((char=? (nthchar a n) (nthchar b n) ) (aux (+ 1 n) a b))
+ ('#t (char<? (nthchar b n) (nthchar a n)))))))
+ (aux 0 a b)))
+
+(define (string<? a b) (string>? b a))
+(define (string<=? a b) (not (string>? a b)))
+(define (string>=? a b) (not (string<? a 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)))
+
+(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 <blume@cs.Princeton.EDU>
+;;; 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 <string>)
+ getenv ;posix (getenv <string>)
+ 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 <port>)
+(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? <string>)
+(define (file-exists? f)
+ (system (string-append "test -f " f)))
+
+;;; (DELETE-FILE <string>)
+(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 <pathname>)
+ (slib:eval-load <pathname> defmacro:eval))
+
+(define (slib:eval-load <pathname> evl)
+ (if (not (file-exists? <pathname>))
+ (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <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))
+ ;; (key<? #F read-only true)
+ ;; (alist->tree #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 key<? alist->tree
+ add insert!
+ delete delete!
+ member? lookup
+ split-lt split-gt
+ union intersection
+ difference subset?
+ rank )
+ (vector tag:tree-type
+ key<? alist->tree 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/key<? tt) (vector-ref tt 1))
+ (define (tree-type/alist->tree 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<?
+ ;;
+
+ (define (node/min node)
+ (cond ((empty? node) (error:empty 'min))
+ ((empty? (node/l node)) node)
+ (else (node/min (node/l node)))))
+
+ (define (node/delmin node)
+ (cond ((empty? node) (error:empty 'delmin))
+ ((empty? (node/l node)) (node/r node))
+ (else (t-join (node/k node) (node/v node)
+ (node/delmin (node/l node)) (node/r node)))))
+
+ (define (node/concat2 node1 node2)
+ (cond ((empty? node1) node2)
+ ((empty? node2) node1)
+ (else
+ (let ((min-node (node/min node2)))
+ (t-join (node/k min-node) (node/v min-node)
+ node1 (node/delmin node2))))))
+
+ (define (node/inorder-fold procedure base node)
+ (define (fold base node)
+ (if (empty? node)
+ base
+ (with-n-node node
+ (lambda (k v l r)
+ (fold (procedure k v (fold base r)) l)))))
+ (fold base node))
+
+ (define (node/for-each procedure node)
+ (if (not (empty? node))
+ (with-n-node node
+ (lambda (k v l r)
+ (node/for-each procedure l)
+ (procedure k v)
+ (node/for-each procedure r)))))
+
+ (define (node/height node)
+ (if (empty? node)
+ 0
+ (+ 1 (max (node/height (node/l node))
+ (node/height (node/r node))))))
+
+ (define (node/index node index)
+ (define (loop node index)
+ (let ((size.l (node/size (node/l node))))
+ (cond ((fix:< index size.l) (loop (node/l node) index))
+ ((fix:> 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<?)
+
+ ;; MIT-Scheme definitions:
+ ;;(declare (integrate key<?))
+ ;;(define-integrable (key>? x y) (key<? y x))
+
+ (define (key>? x y) (key<? y x))
+
+ (define (node/find k node)
+ ;; Returns either the node or #f.
+ ;; Loop takes D comparisons where D is the depth of the tree
+ ;; rather than the traditional compare-low, compare-high which
+ ;; takes on average 1.5(D-1) comparisons
+ (define (loop this best)
+ (cond ((empty? this) best)
+ ((key<? k (node/k this)) (loop (node/l this) best))
+ (else (loop (node/r this) this))))
+ (let ((best (loop node #f)))
+ (cond ((not best) #f)
+ ((key<? (node/k best) k) #f)
+ (else best))))
+
+ (define (node/rank k node rank)
+ (cond ((empty? node) #f)
+ ((key<? k (node/k node)) (node/rank k (node/l node) rank))
+ ((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 key) (t-join key val (node/add l k v) r))
+ ((key<? key k) (t-join key val l (node/add r k v)))
+ (else (n-join key v l r)))))))
+
+ (define (node/delete x node)
+ (if (empty? node)
+ empty
+ (with-n-node node
+ (lambda (key val l r)
+ (cond ((key<? x key) (t-join key val (node/delete x l) r))
+ ((key<? key x) (t-join key val l (node/delete x r)))
+ (else (node/concat2 l r)))))))
+
+ (define (node/concat tree1 tree2)
+ (cond ((empty? tree1) tree2)
+ ((empty? tree2) tree1)
+ (else
+ (let ((min-node (node/min tree2)))
+ (node/concat3 (node/k min-node) (node/v min-node) tree1
+ (node/delmin tree2))))))
+
+ (define (node/concat3 k v l r)
+ (cond ((empty? l) (node/add r k v))
+ ((empty? r) (node/add l k v))
+ (else
+ (let ((n1 (node/size l))
+ (n2 (node/size r)))
+ (cond ((fix:< (fix:* wt-tree-ratio n1) n2)
+ (with-n-node r
+ (lambda (k2 v2 l2 r2)
+ (t-join k2 v2 (node/concat3 k v l l2) r2))))
+ ((fix:< (fix:* wt-tree-ratio n2) n1)
+ (with-n-node l
+ (lambda (k1 v1 l1 r1)
+ (t-join k1 v1 l1 (node/concat3 k v r1 r)))))
+ (else
+ (n-join k v l r)))))))
+
+ (define (node/split-lt node x)
+ (cond ((empty? node) empty)
+ ((key<? x (node/k node))
+ (node/split-lt (node/l node) x))
+ ((key<? (node/k node) x)
+ (node/concat3 (node/k node) (node/v node) (node/l node)
+ (node/split-lt (node/r node) x)))
+ (else (node/l node))))
+
+ (define (node/split-gt node x)
+ (cond ((empty? node) empty)
+ ((key<? (node/k node) x)
+ (node/split-gt (node/r node) x))
+ ((key<? x (node/k node))
+ (node/concat3 (node/k node) (node/v node)
+ (node/split-gt (node/l node) x) (node/r node)))
+ (else (node/r node))))
+
+ (define (node/union tree1 tree2)
+ (cond ((empty? tree1) tree2)
+ ((empty? tree2) tree1)
+ (else
+ (with-n-node tree2
+ (lambda (ak av l r)
+ (let ((l1 (node/split-lt tree1 ak))
+ (r1 (node/split-gt tree1 ak)))
+ (node/concat3 ak av (node/union l1 l) (node/union r1 r))))))))
+
+ (define (node/difference tree1 tree2)
+ (cond ((empty? tree1) empty)
+ ((empty? tree2) tree1)
+ (else
+ (with-n-node tree2
+ (lambda (ak av l r)
+ (let ((l1 (node/split-lt tree1 ak))
+ (r1 (node/split-gt tree1 ak)))
+ av
+ (node/concat (node/difference l1 l)
+ (node/difference r1 r))))))))
+
+ (define (node/intersection tree1 tree2)
+ (cond ((empty? tree1) empty)
+ ((empty? tree2) empty)
+ (else
+ (with-n-node tree2
+ (lambda (ak av l r)
+ (let ((l1 (node/split-lt tree1 ak))
+ (r1 (node/split-gt tree1 ak)))
+ (if (node/find ak tree1)
+ (node/concat3 ak av (node/intersection l1 l)
+ (node/intersection r1 r))
+ (node/concat (node/intersection l1 l)
+ (node/intersection r1 r)))))))))
+
+ (define (node/subset? tree1 tree2)
+ (or (empty? tree1)
+ (and (fix:<= (node/size tree1) (node/size tree2))
+ (with-n-node tree1
+ (lambda (k v l r)
+ v
+ (cond ((key<? k (node/k tree2))
+ (and (node/subset? l (node/l tree2))
+ (node/find k tree2)
+ (node/subset? r tree2)))
+ ((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
+ key<? ; key<?
+ alist->tree ; 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<?))
+
+ 'done)
+
+;;; Local Variables:
+;;; eval: (put 'with-n-node 'scheme-indent-function 1)
+;;; eval: (put 'with-n-node 'scheme-indent-hook 1)
+;;; End:
diff --git a/yasyn.scm b/yasyn.scm
new file mode 100644
index 0000000..12228f4
--- /dev/null
+++ b/yasyn.scm
@@ -0,0 +1,201 @@
+;;"yasyn.scm" YASOS in terms of "object.scm"
+;;;From: whumeniu@datap.ca (Wade Humeniuk)
+
+(require 'object)
+
+(define yasos:instance? object?)
+;; Removed (define yasos:make-instance 'bogus) ;;
+;; Removed (define-syntax YASOS:INSTANCE-DISPATCHER ;; alias so compiler can inline for speed
+;; (syntax-rules () ((yasos:instance-dispatcher inst) (cdr inst))))
+;; DEFINE-OPERATION
+
+(define-syntax define-operation
+ (syntax-rules ()
+ ((define-operation (<name> <inst> <arg> ...) <exp1> <exp2> ...)
+ ;;=>
+ (define <name> (make-generic-method
+ (lambda (<inst> <arg> ...) <exp1> <exp2> ...))))
+
+ ((define-operation (<name> <inst> <arg> ...) ) ;; no body
+ ;;=>
+ (define-operation (<name> <inst> <arg> ...)
+ (slib:error "Operation not handled"
+ '<name>
+ (format #f (if (yasos:instance? <inst>) "#<INSTANCE>" "~s")
+ <inst>))))))
+
+;; DEFINE-PREDICATE
+
+(define-syntax define-predicate
+ (syntax-rules ()
+ ((define-predicate <name>)
+ ;;=>
+ (define <name> (make-generic-predicate)))))
+
+;; OBJECT
+
+(define-syntax object
+ (syntax-rules ()
+ ((object ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
+ ;;=>
+ (let ((self (make-object)))
+ (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...))
+ ...
+ self))))
+
+;; OBJECT with MULTIPLE INHERITANCE {First Found Rule}
+
+(define-syntax object-with-ancestors
+ (syntax-rules ()
+ ((object-with-ancestors ( (<ancestor1> <init1>) ... )
+ ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
+ ;;=>
+ (let* ((<ancestor1> <init1>)
+ ...
+ (self (make-object <ancestor1> ...)))
+ (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...))
+ ...
+ self))))
+
+;; OPERATE-AS {a.k.a. send-to-super}
+
+; used in operations/methods
+
+(define-syntax operate-as
+ (syntax-rules ()
+ ((operate-as <component> <op> <composit> <arg> ...) ;; What is <composit> ???
+ ;;=>
+ ((get-method <component> <op>) <composit> <arg> ...))))
+
+
+
+;; SET & SETTER
+
+
+(define-syntax set
+ (syntax-rules ()
+ ((set (<access> <index> ...) <newval>)
+ ((yasos:setter <access>) <index> ... <newval>)
+ )
+ ((set <var> <newval>)
+ (set! <var> <newval>)
+ )
+) )
+
+
+(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 <name>)
+ (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" <name> inst))
+ ) )
+ )
+ )
+
+ self
+) )
+
+(define-syntax define-access-operation
+ (syntax-rules ()
+ ((define-access-operation <name>)
+ ;=>
+ (define <name> (yasos:make-access-operation '<name>))
+) ) )
+
+
+
+;;---------------------
+;; general operations
+;;---------------------
+
+(define-operation (yasos:print obj port)
+ (format port
+ ;; if an instance does not have a PRINT operation..
+ (if (yasos:instance? obj) "#<INSTANCE>" "~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)