diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
commit | 8ffbc2df0fde83082610149d24e594c1cd879f4a (patch) | |
tree | a2be9aad5101c5e450ad141d15c514bc9c2a2963 | |
download | slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip |
Import Upstream version 2a6upstream/2a6
-rw-r--r-- | ANNOUNCE | 70 | ||||
-rw-r--r-- | ChangeLog | 1094 | ||||
-rw-r--r-- | FAQ | 216 | ||||
-rw-r--r-- | Makefile | 229 | ||||
-rw-r--r-- | README | 220 | ||||
-rw-r--r-- | Template.scm | 267 | ||||
-rw-r--r-- | alist.scm | 66 | ||||
-rw-r--r-- | alistab.scm | 227 | ||||
-rw-r--r-- | array.scm | 279 | ||||
-rw-r--r-- | arraymap.scm | 76 | ||||
-rw-r--r-- | batch.scm | 417 | ||||
-rw-r--r-- | break.scm | 151 | ||||
-rw-r--r-- | chap.scm | 150 | ||||
-rw-r--r-- | charplot.scm | 142 | ||||
-rw-r--r-- | chez.init | 266 | ||||
-rw-r--r-- | cltime.scm | 74 | ||||
-rw-r--r-- | collect.scm | 236 | ||||
-rw-r--r-- | comlist.scm | 326 | ||||
-rw-r--r-- | comparse.scm | 92 | ||||
-rw-r--r-- | dbrowse.scm | 98 | ||||
-rw-r--r-- | dbutil.scm | 222 | ||||
-rw-r--r-- | debug.scm | 78 | ||||
-rw-r--r-- | defmacex.scm | 96 | ||||
-rw-r--r-- | dwindtst.scm | 80 | ||||
-rw-r--r-- | dynamic.scm | 75 | ||||
-rw-r--r-- | dynwind.scm | 74 | ||||
-rw-r--r-- | elk.init | 281 | ||||
-rw-r--r-- | factor.scm | 149 | ||||
-rw-r--r-- | fluidlet.scm | 45 | ||||
-rw-r--r-- | format.scm | 1678 | ||||
-rw-r--r-- | formatst.scm | 647 | ||||
-rw-r--r-- | gambit.init | 219 | ||||
-rw-r--r-- | genwrite.scm | 264 | ||||
-rw-r--r-- | getopt.scm | 80 | ||||
-rw-r--r-- | hash.scm | 153 | ||||
-rw-r--r-- | hashtab.scm | 79 | ||||
-rw-r--r-- | lineio.scm | 50 | ||||
-rw-r--r-- | logical.scm | 150 | ||||
-rw-r--r-- | macrotst.scm | 54 | ||||
-rw-r--r-- | macscheme.init | 265 | ||||
-rw-r--r-- | macwork.scm | 126 | ||||
-rw-r--r-- | makcrc.scm | 86 | ||||
-rw-r--r-- | mbe.scm | 362 | ||||
-rw-r--r-- | mitcomp.pat | 1466 | ||||
-rw-r--r-- | mitscheme.init | 254 | ||||
-rw-r--r-- | modular.scm | 158 | ||||
-rw-r--r-- | mulapply.scm | 28 | ||||
-rw-r--r-- | mularg.scm | 10 | ||||
-rw-r--r-- | mwdenote.scm | 273 | ||||
-rw-r--r-- | mwexpand.scm | 548 | ||||
-rw-r--r-- | mwsynrul.scm | 343 | ||||
-rw-r--r-- | obj2str.scm | 61 | ||||
-rw-r--r-- | object.scm | 97 | ||||
-rw-r--r-- | paramlst.scm | 215 | ||||
-rw-r--r-- | plottest.scm | 47 | ||||
-rw-r--r-- | pp.scm | 12 | ||||
-rw-r--r-- | ppfile.scm | 70 | ||||
-rw-r--r-- | primes.scm | 181 | ||||
-rw-r--r-- | printf.scm | 278 | ||||
-rw-r--r-- | priorque.scm | 141 | ||||
-rw-r--r-- | process.scm | 68 | ||||
-rw-r--r-- | promise.scm | 29 | ||||
-rw-r--r-- | qp.scm | 149 | ||||
-rw-r--r-- | queue.scm | 72 | ||||
-rw-r--r-- | r4rsyn.scm | 542 | ||||
-rw-r--r-- | randinex.scm | 99 | ||||
-rw-r--r-- | random.scm | 101 | ||||
-rw-r--r-- | ratize.scm | 13 | ||||
-rw-r--r-- | rdms.scm | 598 | ||||
-rw-r--r-- | recobj.scm | 54 | ||||
-rw-r--r-- | record.scm | 211 | ||||
-rw-r--r-- | repl.scm | 92 | ||||
-rw-r--r-- | report.scm | 116 | ||||
-rw-r--r-- | require.scm | 348 | ||||
-rw-r--r-- | root.scm | 149 | ||||
-rw-r--r-- | sc2.scm | 66 | ||||
-rw-r--r-- | sc4opt.scm | 53 | ||||
-rw-r--r-- | sc4sc3.scm | 35 | ||||
-rw-r--r-- | scaexpp.scm | 2956 | ||||
-rw-r--r-- | scaglob.scm | 32 | ||||
-rw-r--r-- | scainit.scm | 103 | ||||
-rw-r--r-- | scamacr.scm | 181 | ||||
-rw-r--r-- | scanf.scm | 351 | ||||
-rw-r--r-- | scaoutp.scm | 93 | ||||
-rw-r--r-- | scheme2c.init | 291 | ||||
-rw-r--r-- | scheme48.init | 239 | ||||
-rw-r--r-- | scmacro.scm | 119 | ||||
-rw-r--r-- | scmactst.scm | 160 | ||||
-rw-r--r-- | sierpinski.scm | 71 | ||||
-rw-r--r-- | slib.info | 153 | ||||
-rw-r--r-- | slib.info-1 | 1306 | ||||
-rw-r--r-- | slib.info-2 | 1193 | ||||
-rw-r--r-- | slib.info-3 | 859 | ||||
-rw-r--r-- | slib.info-4 | 1248 | ||||
-rw-r--r-- | slib.info-5 | 1536 | ||||
-rw-r--r-- | slib.info-6 | 1410 | ||||
-rw-r--r-- | slib.info-7 | 615 | ||||
-rw-r--r-- | slib.info-8 | 570 | ||||
-rw-r--r-- | slib.texi | 9058 | ||||
-rw-r--r-- | sort.scm | 154 | ||||
-rw-r--r-- | soundex.scm | 82 | ||||
-rw-r--r-- | stdio.scm | 7 | ||||
-rw-r--r-- | strcase.scm | 45 | ||||
-rw-r--r-- | strport.scm | 51 | ||||
-rw-r--r-- | strsrch.scm | 95 | ||||
-rw-r--r-- | struct.scm | 165 | ||||
-rw-r--r-- | structst.scm | 37 | ||||
-rw-r--r-- | structure.scm | 80 | ||||
-rw-r--r-- | syncase.sh | 146 | ||||
-rw-r--r-- | synchk.scm | 104 | ||||
-rw-r--r-- | synclo.scm | 748 | ||||
-rw-r--r-- | synrul.scm | 327 | ||||
-rw-r--r-- | t3.init | 425 | ||||
-rw-r--r-- | tek40.scm | 92 | ||||
-rw-r--r-- | tek41.scm | 147 | ||||
-rw-r--r-- | time.scm | 158 | ||||
-rw-r--r-- | trace.scm | 106 | ||||
-rw-r--r-- | tree.scm | 62 | ||||
-rw-r--r-- | trnscrpt.scm | 76 | ||||
-rw-r--r-- | tsort.scm | 46 | ||||
-rw-r--r-- | values.scm | 27 | ||||
-rw-r--r-- | vscm.init | 306 | ||||
-rw-r--r-- | withfile.scm | 82 | ||||
-rw-r--r-- | wttest.scm | 134 | ||||
-rw-r--r-- | wttree.scm | 784 | ||||
-rw-r--r-- | yasyn.scm | 201 |
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?. @@ -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) @@ -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)))) @@ -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") @@ -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) @@ -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)))))))) @@ -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)) @@ -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) |