diff options
author | Keisuke Nishida <kxn30@po.cwru.edu> | 2001-04-14 11:24:45 +0000 |
---|---|---|
committer | Keisuke Nishida <kxn30@po.cwru.edu> | 2001-04-14 11:24:45 +0000 |
commit | 9ddacf866c266685c94638b1fa13ac129670d18e (patch) | |
tree | 5f01ec896cb27a407e196d757a8ca2a41bf30444 | |
parent | 92e7e03faec2d8f46d3bb2325232ab69f3531ffe (diff) | |
download | guile-9ddacf866c266685c94638b1fa13ac129670d18e.tar.gz |
Import SLIB 2d1.
165 files changed, 61896 insertions, 0 deletions
diff --git a/module/slib/ANNOUNCE b/module/slib/ANNOUNCE new file mode 100644 index 000000000..d8a00b585 --- /dev/null +++ b/module/slib/ANNOUNCE @@ -0,0 +1,171 @@ +This message announces the availability of Scheme Library release slib2d1. + +New in slib2d1: + + + Linux RPM distribution. + + + Automated generation of HTTP/HTML static and (multi-client) + dynamically editable tables from relational databases. + (HTTP server demo at http://www.foxkid.net:8143/tla/). + + + Reference implementation of Metric Interchange Format: + "Representation of numerical values and SI units in character strings + for information interchanges" + http://swissnet.ai.mit.edu/~jaffer/MIXF.html + + * Makefile (rpm): Added to dist target. + (mfiles): Added slib.spec. + * slib.spec: Added spec file to generate a .rpm file. + Largely based on that of Dr. Robert J. Meier + <robert.meier@computer.org> + * Makefile (docfiles): Added all the *.txi. + * db2html.scm (HTML editing tables): Replaced "record" with "row". + * http-cgi.scm (query-alist->parameter-list): Null string --> #f. + * coerce.scm (type-of): Removed 'null; broke (coerce '() 'string). + * htmlform.scm (html:meta, html:http-equiv): Added. + * htmlform.scm (html:meta-refresh): Added. + * http-cgi.scm (query-alist->parameter-list): Only separate words + for nary parameters. + * getparam.scm (getopt->parameter-list): Accomodate positional + arguments, both ends. + (getopt->parameter-list, getopt->arglist): Take optional + description strings. + * db2html.scm (command:make-editable-table): Added optional + arguments passed to command:modify-table. + (command:modify-table): Added null-keys argument; removed pkl. + * http-cgi.scm (http:forwarding-page): Added. + * htmlform.scm (html:text-area): fixed. + * http-cgi.scm (coerce->list): Added. + * paramlst.scm (check-arities): Generate warning for wrong arity. + * db2html.scm (command:make-editable-table): Deduce arities. + * comlist.scm (comlist:list-of??): Added. + * coerce.scm (coerce, type-of): Extracted from comlist.scm. + * uri.scm (uri:path->keys): Takes list of type-symbols. + * simetrix.scm (SI:unit-infos): bit is "bit" (not b). + * uri.scm (uri:decode-path, uri:path->keys): Now take path-list + instead of path. Fixes bug when '/' was in URI path. + * http-cgi.scm (make-query-alist-command-server): Renamed from + make-uriencoded-command-server; takes query-alist instead of + query-string. Diagnostics can use query-alist without recreating. + * db2html.scm (html:linked-row-converter): If a field has a + foreign-key of "*catalog-data*", then link to foreign table. + (catalog->html, table->linked-html): Put caption at BOTTOM. + * htmlform.scm (command->p-specs): Renamed from command->html + because it has changed so much. No longer does mapper argument. + * db2html.scm (command:make-editable-table): Returns editing-row + procedure. + * htmlform.scm (html:select, html:buttons, form:element, + form:delimited): value-list and visibles arguments combined. + * dbutil.scm (get-foreign-choices): extracted from command->html. + (make-defaulter): Added. + * strcase.scm (symbol-append): Added. + * http-cgi.scm (make-uriencoded-command-server): Only apply comval + if arglist worked. + * htmlform.scm (command->html): Big change; returns list of + results of application of (new) MAPPER argument. + (form:delimited, form:tabled): Added MAPPER procedures. + * db2html.scm (html:editable-row-converter): Check for + edit-converter being #f. + (command:make-editable-table): *keys*, *row-hash* NOT optional. + * htmlform.scm (form:element): Extracted from html:generate-form. + * db2html.scm (html:editable-row-converter): Added. + (command:modify-table): Handle case all fields are primary keys. + * db2html.scm (command:modify-table, command:make-editable-table): + (HTML editing tables): Added. + * htmlform.scm (form:submit): Enhanced. + * uri.scm (uri:decode-authority, make-uri): en/decode userinfo. + (uri:make-path): Added. + (read-anchor-string): Removed; just use paths for combined keys. + * slib.texi (Lists as sets): Examples had incorrect order in + returned lists. + * uri.scm (html:base, html:isindex): Added. + (uri->tree): Optional base-tree argument added for relative URI. + Brought into full conformance with RFC 2396 test cases. + * uri.scm (html:anchor, html:link uri->tree make-uri): Added. + (uri:split-fields, uri:decode-query): Moved and renamed from + http-cgi.scm. + * htmlform.scm (form:image): Added. + * uri.scm: Added collected URI functions from "http-cgi.scm" and + "db2html.scm". + * makcrc.scm (make-port-crc): Added CRC-16 default. Can now take + just generator argument. + * db2html.scm (html:linked-row-converter, table->linked-html, + table->linked-page, db->html-files, db->html-directory): more + evocative names. + (html:catalog-row-converter): Stripped down version for catalog. + * pp.scm (pretty-print->string): Added. + (pp:pretty-print): Use (output-port-width port) for width. + * genwrite.scm (genwrite:newline-str): abstracted. + * htmlform.scm (html:pre): Improved HTML formatting. + * http-cgi.scm (query-alist->parameter-list): Made robust for + unexpected option-names; and generates warning. + * db2html.scm: Fixed HTML per http://validator.w3.org/check. + * simetrix.scm (SI:conversion-factor): Negative return codes. + * simetrix.scm (SI:unit-infos): Added katal. Replaced bel (B) + with decibel (dB). + (SI:prefix-exponents): Added [IEC 60027-2] binary prefixes. + (SI:unit-infos): Added bit and byte (B). + * simetrix.scm (SI:unit-infos): Updated eV and u from CODATA-1998. + (SI:solidus): Abstracted parse functions. + * simetrix.scm: SI Metric Interchange Format for Scheme Added. + * scanf.scm (stdio:scan-and-set read-ui): Fixed dependence on LET + evaluation order. + * schmooz.texi: Split out from slib.texi. + * printf.scm (stdio:parse-float): Adjust so %e format prints an + exponent of zero for 0.0 + * dbutil.scm (dbutil:list-table-definition): Added. + * db2html.scm (html:caption): Split out from html:table. + * rdms.scm (sync-database): Added. + * pnm.scm (pnm:array-write): PGMs were always being written with + 15 for maxval. + * http-cgi.scm (make-urlencoded-command-server): Uses the value of + *suggest* if *command* is not in the query-string; if neither uses + literal *default*. + * htmlform.scm (html:form html:hidden html:checkbox html:text + html:text-area html:select html:buttons form:submit form:reset): + Procedures documented. No longer builds in <DL> tags. + * htmlform.scm (html:blank): Added. + (html:plain): Returns non-break-space for html:blank. + (html:select html:buttons command->html html:generate-form): Added + support for VISIBLE-NAME field for foreign-key domains. + * debug.scm (for-each-top-level-definition-in-file): define-syntax + is a top-level-definition too. + * makcrc.scm (make-port-crc): Converted to use read-byte. + * htmlform.scm (html:generate-form): was ignoring method. + +From Ben Goetter <goetter@mazama.net> + * pscheme.init: Revised. + +From Lars Arvestad <arve@inddama.sto.se.pnu.com> + * gambit.init (*features*): Gambit 3.0 provides + call-with-input-string and call-with-output-string. + +SLIB is a portable Scheme library providing compatibiliy and utility +functions for all standard Scheme implementations. + +SLIB includes initialization files for Bigloo, Chez, DrScheme, ELK, +GAMBIT, MacScheme, MITScheme, PocketScheme, RScheme Scheme->C, +Scheme48, SCM, SCSH, T3.1, UMB-Scheme, and VSCM. + +Documentation includes a manifest, installation instructions, and +coding guidelines for the library. Documentation of each library +package is supplied. SLIB Documentation is online at: + + http://swissnet.ai.mit.edu/~jaffer/SLIB.html + +SLIB is available from: + http://swissnet.ai.mit.edu/ftpdir/scm/slib2d1.zip + http://swissnet.ai.mit.edu/ftpdir/scm/slib-2d1-1.noarch.rpm + swissnet.ai.mit.edu:/pub/scm/slib2d1.zip + swissnet.ai.mit.edu:/pub/scm/slib-2d1-1.noarch.rpm + +SLIB-PSD is a portable debugger for Scheme (requires emacs editor): + http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.zip + swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.zip + +SCHELOG is an embedding of Prolog in Scheme+SLIB: + http://www.cs.rice.edu/CS/PLT/packages/schelog/ + +Programs for printing and viewing TexInfo documentation (which SLIB +has) come with GNU Emacs or can be obtained via ftp from: + ftp.gnu.org:pub/gnu/texinfo/texinfo-4.0.tar.gz diff --git a/module/slib/Bev2slib.scm b/module/slib/Bev2slib.scm new file mode 100644 index 000000000..24a7c68f6 --- /dev/null +++ b/module/slib/Bev2slib.scm @@ -0,0 +1,94 @@ +;;;; "Bev2slib.scm" Build SLIB catalogs for Stephen Bevan's libraries. +;Copyright (C) 1998 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. + +;;; Put this file into the implementation-vicinity directory for your +;;; scheme implementation. + +;;; Add the line +;;; (load (in-vicinity (implementation-vicinity) "Bev2slib.scm")) +;;; to "mkimpcat.scm" + +;;; Delete "slibcat" in your implementation-vicinity. + +;;; Bind `Bevan-dir' to the directory containing directories "bawk", +;;; "mawk", "pathname", etc. Bev2slib.scm will put entries into the +;;; catalog only for those directories and files which exist. + +(let ((Bevan-dir (in-vicinity (library-vicinity) "../"));"/usr/local/lib/Bevan/" + (catname "sitecat")) + (call-with-output-file (in-vicinity (implementation-vicinity) catname) + (lambda (op) + (define (display* . args) + (for-each (lambda (arg) (display arg op)) args) + (newline op)) + (define (add-alias from to) + (display " " op) + (write (cons from to) op) + (newline op)) + + (begin + (display* ";\"" catname "\" Site-specific SLIB catalog for " + (scheme-implementation-type) (scheme-implementation-version) + ". -*-scheme-*-") + (display* ";") + (display* "; DO NOT EDIT THIS FILE") + (display* "; it is automagically generated by \"Bev2slib.scm\"") + (newline op) + ) + + ;; Output association lists to file "sitecat" + + (for-each + (lambda (dir) + (let* ((vic (in-vicinity Bevan-dir (string-append dir "/"))) + (map-file (in-vicinity vic (string-append dir ".map")))) + + (display* ";;; from " map-file) + (display* "(") + + (and + (file-exists? map-file) + (call-with-input-file map-file + (lambda (ip) + (define files '()) + (do ((feature (read ip) (read ip))) + ((eof-object? feature)) + (let* ((type (read ip)) + (file (read ip)) + (fsym (string->symbol (string-append "Req::" file)))) + (and (not (assq fsym files)) + (set! files (cons (cons fsym file) files))) + (add-alias feature fsym))) + (for-each + (lambda (pr) (add-alias (car pr) (in-vicinity vic (cdr pr)))) + files) + ))) + + (display* ")"))) + + '("char-set" "conc-string" "string" "string-03" + "avl-tree" "avl-trie" + "bawk" "mawk" "pathname")) + + (begin + (display* "(") + (add-alias 'btree (in-vicinity Bevan-dir "bawk/btree")) + (add-alias 'read-line 'line-i/o) + (display* ")") + )))) diff --git a/module/slib/ChangeLog b/module/slib/ChangeLog new file mode 100644 index 000000000..9c71f1f47 --- /dev/null +++ b/module/slib/ChangeLog @@ -0,0 +1,2604 @@ +2001-03-18 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (rpm): Fixed dependencies. + +Thu Mar 15 20:52:30 EST 2001 Aubrey Jaffer <jaffer@aubrey.jaffer> + + * require.scm (*SLIB-VERSION*): Bumped from 2c9 to 2d1. + +2001-03-15 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (rpm): Added to dist target. + (mfiles): Added slib.spec. + +2001-03-15 Radey Shouman <Shouman@ne.mediaone.net> + + * slib.spec: Added spec file to generate a .rpm file. + Largely based on that of Dr. Robert J. Meier + <robert.meier@computer.org> + +2001-03-13 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (docfiles): Added all the *.txi. + + * db2html.scm (HTML editing tables): Replaced "record" with "row". + + * http-cgi.scm (query-alist->parameter-list): Null string --> #f. + +2001-03-12 Aubrey Jaffer <agj@alum.mit.edu> + + * coerce.scm (type-of): Removed 'null; broke (coerce '() 'string). + +2001-03-09 Aubrey Jaffer <agj@alum.mit.edu> + + * htmlform.scm (html:meta, html:http-equiv): Added. + +2001-03-04 Aubrey Jaffer <agj@alum.mit.edu> + + * htmlform.scm (html:meta-refresh): Added. + +2001-02-28 Aubrey Jaffer <agj@alum.mit.edu> + + * http-cgi.scm (query-alist->parameter-list): Only separate words + for nary parameters. + + * getparam.scm (getopt->parameter-list): Accomodate positional + arguments, both ends. + (getopt->parameter-list, getopt->arglist): Take optional + description strings. + +2001-02-27 Aubrey Jaffer <agj@alum.mit.edu> + + * db2html.scm (command:make-editable-table): Added optional + arguments passed to command:modify-table. + (command:modify-table): Added null-keys argument; removed pkl. + + * http-cgi.scm (http:forwarding-page): Added. + +2001-02-25 Aubrey Jaffer <agj@alum.mit.edu> + + * htmlform.scm (html:text-area): fixed. + + * http-cgi.scm (coerce->list): Added. + + * paramlst.scm (check-arities): Generate warning for wrong arity. + + * db2html.scm (command:make-editable-table): Deduce arities. + + * comlist.scm (comlist:list-of??): Added. + +2001-02-24 Aubrey Jaffer <agj@alum.mit.edu> + + * coerce.scm (coerce, type-of): Extracted from comlist.scm. + +2001-02-16 Aubrey Jaffer <agj@alum.mit.edu> + + * uri.scm (uri:path->keys): Takes list of type-symbols. + + * simetrix.scm (SI:unit-infos): bit is "bit" (not b). + +2001-02-12 Aubrey Jaffer <agj@alum.mit.edu> + + * uri.scm (uri:decode-path, uri:path->keys): Now take path-list + instead of path. Fixes bug when '/' was in URI path. + + * http-cgi.scm (make-query-alist-command-server): Renamed from + make-uriencoded-command-server; takes query-alist instead of + query-string. Diagnostics can use query-alist without recreating. + + * db2html.scm (html:linked-row-converter): If a field has a + foreign-key of "*catalog-data*", then link to foreign table. + (catalog->html, table->linked-html): Put caption at BOTTOM. + +2001-02-11 Aubrey Jaffer <agj@alum.mit.edu> + + * htmlform.scm (command->p-specs): Renamed from command->html + because it has changed so much. No longer does mapper argument. + +2001-02-08 Aubrey Jaffer <agj@alum.mit.edu> + + * db2html.scm (command:make-editable-table): Returns editing-row + procedure. + + * htmlform.scm (html:select, html:buttons, form:element, + form:delimited): value-list and visibles arguments combined. + + * dbutil.scm (get-foreign-choices): extracted from command->html. + (make-defaulter): Added. + +2001-02-07 Aubrey Jaffer <agj@alum.mit.edu> + + * strcase.scm (symbol-append): Added. + + * http-cgi.scm (make-uriencoded-command-server): Only apply comval + if arglist worked. + + * htmlform.scm (command->html): Big change; returns list of + results of application of (new) MAPPER argument. + (form:delimited, form:tabled): Added MAPPER procedures. + + * db2html.scm (html:editable-row-converter): Check for + edit-converter being #f. + (command:make-editable-table): *keys*, *row-hash* NOT optional. + +2001-02-06 Aubrey Jaffer <agj@alum.mit.edu> + + * htmlform.scm (form:element): Extracted from html:generate-form. + + * db2html.scm (html:editable-row-converter): Added. + (command:modify-table): Handle case all fields are primary keys. + +2001-02-04 Aubrey Jaffer <agj@alum.mit.edu> + + * db2html.scm (command:modify-table, command:make-editable-table): + (HTML editing tables): Added. + + * htmlform.scm (form:submit): Enhanced. + +2001-01-30 Aubrey Jaffer <agj@alum.mit.edu> + + * uri.scm (uri:decode-authority, make-uri): en/decode userinfo. + (uri:make-path): Added. + (read-anchor-string): Removed; just use paths for combined keys. + + * slib.texi (Lists as sets): Examples had incorrect order in + returned lists. + + * uri.scm (html:base, html:isindex): Added. + (uri->tree): Optional base-tree argument added for relative URI. + Brought into full conformance with RFC 2396 test cases. + +2001-01-28 Aubrey Jaffer <agj@alum.mit.edu> + + * uri.scm (html:anchor, html:link uri->tree make-uri): Added. + (uri:split-fields, uri:decode-query): Moved and renamed from + http-cgi.scm. + + * htmlform.scm (form:image): Added. + +2001-01-27 Aubrey Jaffer <agj@alum.mit.edu> + + * uri.scm: Added collected URI functions from "http-cgi.scm" and + "db2html.scm". + +2001-01-25 Aubrey Jaffer <agj@alum.mit.edu> + + * makcrc.scm (make-port-crc): Added CRC-16 default. Can now take + just generator argument. + + * db2html.scm (html:linked-row-converter, table->linked-html, + table->linked-page, db->html-files, db->html-directory): more + evocative names. + (html:catalog-row-converter): Stripped down version for catalog. + + * pp.scm (pretty-print->string): Added. + (pp:pretty-print): Use (output-port-width port) for width. + + * genwrite.scm (genwrite:newline-str): abstracted. + + * htmlform.scm (html:pre): Improved HTML formatting. + +2001-01-24 Aubrey Jaffer <agj@alum.mit.edu> + + * http-cgi.scm (query-alist->parameter-list): Made robust for + unexpected option-names; and generates warning. + +2001-01-23 Aubrey Jaffer <agj@alum.mit.edu> + + * db2html.scm: Fixed HTML per http://validator.w3.org/check. + +2001-01-20 Aubrey Jaffer <agj@alum.mit.edu> + + * simetrix.scm (SI:conversion-factor): Negative return codes. + +2001-01-16 Aubrey Jaffer <agj@alum.mit.edu> + + * simetrix.scm (SI:unit-infos): Added katal. Replaced bel (B) + with decibel (dB). + (SI:prefix-exponents): Added [IEC 60027-2] binary prefixes. + (SI:unit-infos): Added bit and byte (B). + +2001-01-15 Aubrey Jaffer <agj@alum.mit.edu> + + * simetrix.scm (SI:unit-infos): Updated eV and u from CODATA-1998. + (SI:solidus): Abstracted parse functions. + +2001-01-14 Aubrey Jaffer <agj@alum.mit.edu> + + * simetrix.scm: SI Metric Interchange Format for Scheme Added. + +2001-01-11 Aubrey Jaffer <agj@alum.mit.edu> + + * scanf.scm (stdio:scan-and-set read-ui): Fixed dependence on LET + evaluation order. + +2001-01-04 Ben Goetter <goetter@mazama.net> + + * pscheme.init: Revised. + +2001-01-04 Lars Arvestad <arve@inddama.sto.se.pnu.com> + + * gambit.init (*features*): Gambit 3.0 provides + call-with-input-string and call-with-output-string. + +2000-12-21 Aubrey Jaffer <agj@alum.mit.edu> + + * schmooz.texi: Split out from slib.texi. + +2000-12-13 Radey Shouman <Shouman@ne.mediaone.net> + + * printf.scm (stdio:parse-float): Adjust so %e format prints an + exponent of zero for 0.0 + +2000-12-12 Aubrey Jaffer <agj@alum.mit.edu> + + * dbutil.scm (dbutil:list-table-definition): Added. + +2000-12-11 Aubrey Jaffer <agj@alum.mit.edu> + + * db2html.scm (html:caption): Split out from html:table. + +2000-12-04 Aubrey Jaffer <agj@alum.mit.edu> + + * rdms.scm (sync-database): Added. + +2000-10-30 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * pnm.scm (pnm:array-write): PGMs were always being written with + 15 for maxval. + +2000-10-22 Aubrey Jaffer <jaffer@ai.mit.edu> + + * http-cgi.scm (make-urlencoded-command-server): Uses the value of + *suggest* if *command* is not in the query-string; if neither uses + literal *default*. + + * htmlform.scm (html:form html:hidden html:checkbox html:text + html:text-area html:select html:buttons form:submit form:reset): + Procedures documented. No longer builds in <DL> tags. + +2000-10-16 Aubrey Jaffer <jaffer@ai.mit.edu> + + * htmlform.scm (html:blank): Added. + (html:plain): Returns non-break-space for html:blank. + (html:select html:buttons command->html html:generate-form): Added + support for VISIBLE-NAME field for foreign-key domains. + +2000-10-14 Aubrey Jaffer <jaffer@ai.mit.edu> + + * debug.scm (for-each-top-level-definition-in-file): define-syntax + is a top-level-definition too. + + * makcrc.scm (make-port-crc): Converted to use read-byte. + +2000-10-12 Aubrey Jaffer <jaffer@ai.mit.edu> + + * htmlform.scm (html:generate-form): was ignoring method. + +Sat Oct 7 23:09:40 EDT 2000 Aubrey Jaffer <jaffer@aubrey.jaffer> + + * require.scm (*SLIB-VERSION*): Bumped from 2c8 to 2c9. + +2000-10-07 Aubrey Jaffer <jaffer@ai.mit.edu> + + * slib.texi (Installation): Instructions cataloged by + implementation. + +2000-10-03 Aubrey Jaffer <jaffer@ai.mit.edu> + + * DrScheme.init: Added support for DrScheme. + +2000-09-28 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * http-cgi.scm (form:split-lines): Don't return empty strings. + +2000-09-27 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * http-cgi.scm (form-urlencoded->query-alist): Don't convert empty + strings to #f. + +2000-09-26 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * http-cgi.scm (make-urlencoded-command-server): Unifies + form-urlencoded->query-alist, serve-query-alist-command, and + invoke-command-on-parameter-list. + + * paramlst.scm (remove-parameter): Added. + +2000-09-25 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * http-cgi.scm (cgi:serve-query): Added. + + * Makefile, README, mklibcat.scm: Added http-cgi.scm + + * http-cgi.scm: Split off from htmlform.scm. + +2000-09-15 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * randinex.scm (random:solid-sphere!): Return radius. + +2000-09-10 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * htmlform.scm: Major rewrite. html: procedures now return + strings. + + * db2html.scm: Moved html table functions from htmlform.scm. + +2000-08-06 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * htmlform.scm (html:checkbox): Rectified number of arguments + conflict. + (html:hidden): Added. + (html:text, html:checkbox, html:dt-strong-doc): Added functional + procedures; renamed previous with appended `!'. + + * dbutil.scm (make-command-server): *default* command added. + (dbutil:check-domain): Abstracted to top-level procedure. + +2000-08-03 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * charplot.scm (find-scale): Pick arbitrary scale when data has + range of zero. + (plot-function!): Added. + +2000-06-24 Colin Walters <walters@cis.ohio-state.edu> + + * comlist.scm (comlist:intersection, comlist:set-difference, + comlist:remove, comlist:remove-if, comlist:remove-if-not, + comlist:butlast, comlist:butnthcdr): Fixed functions which weren't + properly tail recursive. + +2000-06-26 Aubrey Jaffer <aubrey_jaffer@splashtech.com> + + * pnm.scm: PNM image file functions added. + +2000-06-25 Aubrey Jaffer <jaffer@ai.mit.edu> + + * charplot.scm (charplot:iplot!): Fixed label and axis bug. + +Sat Jun 3 21:26:32 EDT 2000 Aubrey Jaffer <jaffer@ai.mit.edu> + + * require.scm (*SLIB-VERSION*): Bumped from 2c7 to 2c8. + +2000-05-30 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scsh.init vscm.init umbscheme.init t3.init scheme48.init + scheme2c.init mitscheme.init macscheme.init gambit.init chez.init + bigloo.init (find-ratio find-ratio-between): Added rationalize + adjunct procedures. + + * ratize.scm (find-ratio-between find-ratio): Advertised + procedures return list of numerator and denominator. + +2000-05-17 Aubrey Jaffer <jaffer@ai.mit.edu> + + * schmooz.scm (schmooz-tops): Removed gratuitous newlines in texi + output. + +2000-04-22 Aubrey Jaffer <jaffer@ai.mit.edu> + + * alistab.scm (ordered-for-each-key, map-key, for-each-key + delete*): Added primary-limit and column-type-list to arguments. + + * rdms.scm (create-database): Removed warning "file exists". + (open-table): Replaced lone call to make-list. + (for-each-row, row:delete*, get*): Added primary-limit and + column-type-list to arguments. + +2000-04-02 Aubrey Jaffer <jaffer@ai.mit.edu> + + * htmlform.scm (html:start-table): Don't force full width. + (http:serve-uri): Added. + + * db2html.scm: Added. + +2000-03-28 Lars Arvestad <arve@nada.kth.se> + + * minimize.scm (golden-section-search): Added. + +2000-03-20 Aubrey Jaffer <jaffer@ai.mit.edu> + + * genwrite.scm (generic-write, generic-write): Down-cased QUOTE + symbol names (for guile). + +2000-02-14 Radey Shouman <Radey_Shouman@splashtech.com> + + * schmooz.scm (schmooz-tops): Now reads (and ignores) #! comments. + +2000-02-05 Aubrey Jaffer <jaffer@ai.mit.edu> + + * trace.scm (untrack, unstack): Added. + (print-call-stack): Protected bindings. + +2000-01-27 <jaffer@ai.mit.edu> + + * Makefile (slib.info): Conditionalize infobar. + +2000-01-26 Aubrey Jaffer <jaffer@ai.mit.edu> + + * require.scm (require:provided?): Don't catalog:get if not + *catalog*. + +2000-01-24 Radey Shouman <Radey_Shouman@splashtech.com> + + * defmacex.scm (defmacro:expand*): Avert MAP error in case input + code has a DEFMACRO with an improper list as argument list. (The + DEFMACRO still does not take effect). + +2000-01-22 Aubrey Jaffer <jaffer@ai.mit.edu> + + * schmooz.scm (schmooz): replaced non-portable calls to OPEN-FILE. + (schmooz): Fixed behavior when filename has no suffix; discard up + to first semicolon in file. + +2000-01-08 Aubrey Jaffer <jaffer@ai.mit.edu> + + * trace.scm (call-stack-news?): Fixed polarity error. + (debug:trace-procedure): made counts 1-based. + +2000-01-02 Aubrey Jaffer <jaffer@ai.mit.edu> + + * Template.scm, *.init (slib:error, slib:warn): print-call-stack. + + * trace.scm (print-call-stack, call-stack-news?): Added. + + * break.scm (debug:breakpoint): print-call-stack. + +1999-12-29 Aubrey Jaffer <jaffer@ai.mit.edu> + + * trace.scm (track, stack): Added ability to maintain call stack + of selected procedures. + + * debug.scm (trace-all, break-all): Now accept multiple (file) + arguments. + + * Makefile (tagfiles): *.init files added. + +1999-12-18 Aubrey Jaffer <jaffer@ai.mit.edu> + + * mklibcat.scm: Added jfilter. + + * slib.texi (Extra-SLIB Packages): Added jfilter. + +Sun Dec 5 19:54:35 EST 1999 Aubrey Jaffer <jaffer@ai.mit.edu> + + * require.scm (*SLIB-VERSION*): Bumped from 2c6 to 2c7. + +1999-12-04 Aubrey Jaffer <jaffer@ai.mit.edu> + + * charplot.scm (charplot:number->string): printf %g gets rid of + microscopic fractions. + + * printf.scm (%g): Make precision threshold work for both + fractions and integers. + +1999-12-03 Aubrey Jaffer <jaffer@ai.mit.edu> + + * nclients.scm (browse-url-netscape): Try running netscape in + background. + +1999-11-14 Aubrey Jaffer <jaffer@ai.mit.edu> + + * batch.scm (write-batch-line): Added slib:warn. + +1999-11-01 Aubrey Jaffer <jaffer@ai.mit.edu> + + * paramlst.scm (check-parameters): Improved warning. + +1999-10-31 Aubrey Jaffer <jaffer@ai.mit.edu> + + * batch.scm (batch:command): Renamed from batch:system. + (batch:try-command): Renamed from batch:try-system. + (batch:try-chopped-command): Added. + (batch:apply-chop-to-fit): Removed. + +1999-09-29 Radey Shouman <Radey_Shouman@splashtech.com> + + * glob.scm (replace-suffix): Now works. + +1999-09-17 Aubrey Jaffer <jaffer@ai.mit.edu> + + * slib.texi: Put description and URL into slib_toc.html. + +Sun Sep 12 22:45:01 EDT 1999 Aubrey Jaffer <jaffer@ai.mit.edu> + + * require.scm (*SLIB-VERSION*): Bumped from 2c5 to 2c6. + +1999-07-08 Aubrey Jaffer <jaffer@ai.mit.edu> + + * format.scm (format:string-capitalize-first): Renamed from + string-capitalize-first. + (format:list-head): Renamed from list-head. + (string-index): Removed. + +1999-06-07 Radey Shouman <Radey_Shouman@splashtech.com> + + * printf.scm (stdio:parse-float): Now handles strings representing + complex numbers in polar form. + + (stdio:parse-float): Now parses non-real numbers written in + rectangular form. + + (stdio:iprintf): Inexact formats work on non-real numbers assuming + NUMBER->STRING outputs a rectangular format. + + Inexact formats given a string or symbol rather than a number + output "???" if the string cannot be parsed as an inexact number. + +1999-06-06 Aubrey Jaffer <jaffer@ai.mit.edu> + + * fft.scm (fft fft-1): Added. + +1999-06-05 Radey Shouman <Radey_Shouman@splashtech.com> + + * glob.scm (glob:substitute??): (glob:substitute-ci??): Now accept + a procedure or string as template argument, for more general + transformations. + +1999-05-28 Gary T. Leavens <leavens@cs.iastate.edu> + + * chez.init: Updated for Chez Scheme 6.0a. + + * bigloo.init: Added. + +1999-05-18 Aubrey Jaffer <jaffer@ai.mit.edu> + + * printf.scm (stdio:iprintf): Extra arguments are *not* a bug. + +1999-05-08 Aubrey Jaffer <jaffer@ai.mit.edu> + + * lineio.scm (read-line!): fixed to eat trailing newline when line + length equals string length. + +1999-05-08 Ben Goetter <goetter@angrygraycat.com> + + * pscheme.init: String-ports added for version Pscheme 0.3.6. + +1999-05-07 <jaffer@super.jaffer> + + * charplot.scm (plot-function): Added. + (charplot:plot!): Now will accept array argument. + +1999-05-02 Jim Blandy <jimb@savonarola.red-bean.com> + + * format.scm (format:format): If the first argument is the format + string, stick a #f on the front of it, so it is now a valid CL + format argument list. This is easier than changing everyplace + else (like the error formatter) that expects it to be in CL form. + The other clause which explicitly tests for this case is now dead + code; remove it. + (format:format-work): Allow `@' and `:' in either order, as per + modern CL behavior. + (format:num->cardinal): Don't assume that an elseless if returns + '() when the condition is false. + +1999-04-22 Radey Shouman <Radey_Shouman@splashtech.com> + + * root.scm (secant:find-root): Replaced hack to decide on + accepting regula-falsi step with a modified regula-falsi in which + the weight of an "old" function value is repeatedly decreased each + time it is retained. + +1999-04-13 Radey Shouman <Radey_Shouman@splashtech.com> + + * root.scm (secant:find-root): Now checks that a step is actually + of nonzero length, otherwise small tolerances lead to not + stopping. Tuned for the case that one starting point is much + closer to the root than the other. + +1999-04-08 Ben Goetter <goetter@angrygraycat.com> + + * pscheme.init: updated with defmacro for version 0.3.3. + +1999-04-04 Aubrey Jaffer <jaffer@ai.mit.edu> + + * lineio.scm: Fixed @args command in documentation-comment. + +1999-03-27 Aubrey Jaffer <jaffer@ai.mit.edu> + + * strsrch.scm (find-string-from-port?): Fixed so procedure + argument is called at most once per character. + +1999-03-11 Radey Shouman <Radey_Shouman@splashtech.com> + + * fluidlet.scm: Added (require 'common-list-functions), for + MAKE-LIST. + +1999-03-08 Aubrey Jaffer <jaffer@ai.mit.edu> + + * RScheme.init, STk.init, Template.scm, chez.init, elk.init, + gambit.init, macscheme.init, mitscheme.init, pscheme.init, + scheme2c.init, scheme48.init, scsh.init, t3.init, vscm.init: Added + scheme-implementation-home-page definition + +1999-03-04 radey <radey@aubrey.jaffer> + + * root.scm (secant:find-bracketed-root): Added, requires (f x0) + and (f x1) to have opposite signs. + +1999-03-03 Radey Shouman <Radey_Shouman@splashtech.com> + + * printf.scm (stdio:printf): Tweaks to %k format so that the + precision indicates the number of significant digits, as in %g + format. + +1999-03-02 Radey Shouman <Radey_Shouman@splashtech.com> + + * printf.scm (stdio:printf): %k format now uses %f instead of %g + to format the scaled number. + + * root.scm (secant:find-root): Added. + +1999-02-25 Radey Shouman <Radey_Shouman@splashtech.com> + + * printf.scm (stdio:iprintf): Fixed bug in %f format, + (printf "%.1f" 0.001) printed "0", now prints "0.0" + +1999-02-12 Hakan L. Younes <d93-hyo@nada.kth.se> + + * batch.scm, slib.texi: amiga-gcc port. + +1999-02-10 Radey Shouman <Radey_Shouman@splashtech.com> + + * printf.scm (stdio:iprintf): K format now prints no prefix if + exponent is beyond the range of the specified prefixes. + + (stdio:iprintf): Added and corrected SI prefixes, ref + http://physics.nist.gov/cuu/Units/prefixes.html . + + (stdio:iprintf): Added numerical format specifiers %K and %k, + which format like %g, except that an SI prefix is output after the + number, which is scaled accordingly. %K outputs a space between + number and prefix, %k does not. It would be good to allow %f and + %e like formatting, but it's not clear how to fit this into the + format string syntax. + +1999-02-09 Aubrey Jaffer <jaffer@ai.mit.edu> + + * rdms.scm (domains:init-data): added number domain. + +1999-01-30 Matthew Flatt <mflatt@cs.rice.edu> + + * mbe.scm (hyg:untag-quasiquote): Added to fix quasiquote in output. + +1999-01-30 Dorai Sitaram <dorai@cs.rice.edu> + + * mbe.scm (mbe:ellipsis-sub-envs, mbe:append-map): Modified to fix + multiple ellipses problem. + +1999-01-26 Erick Gallesio <eg@unice.fr> + + * STk.init: The actual file. + +1999-01-25 Aubrey Jaffer <jaffer@ai.mit.edu> + + * RScheme.init: added; content is from + http://www.rscheme.org/rs/pg1/RScheme.scm + +1999-01-24 Aubrey Jaffer <jaffer@ai.mit.edu> + + * STk.init: added; content is from + http://kaolin.unice.fr/STk/FAQ/FAQ-1.html#ss1.9 + +1999-01-23 Aubrey Jaffer <jaffer@ai.mit.edu> + + * alistab.scm (open-base): Check file exists before opening it. + +1999-01-21 Aubrey Jaffer <jaffer@ai.mit.edu> + + * htmlform.scm (html:start-page): Extra arguments printed in HEAD + (for META tags). + +1999-01-20 Aubrey Jaffer <jaffer@ai.mit.edu> + + * htmlform.scm (make-atval make-plain): use object->string for + non-atomic arguments. + +1999-01-19 Radey Shouman <Radey_Shouman@splashtech.com> + + * printf.scm (stdio:iprintf): Now reports wrong number of + arguments instead of silently ignoring extra arguments or taking + the CAR of the empty list. + +Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer <jaffer@ai.mit.edu> + + * require.scm (*SLIB-VERSION*): Bumped from 2c4 to 2c5. + +1999-01-12 Aubrey Jaffer <jaffer@ai.mit.edu> + + * mitscheme.init (char-code-limit): Added. Builtin + char-code-limit is 65536 (NOT!) in MITScheme Version 8.0. + +1999-01-11 Aubrey Jaffer <jaffer@ai.mit.edu> + + * batch.scm (batch:apply-chop-to-fit): fixed off-by-1 error. + +1999-01-10 Aubrey Jaffer <jaffer@ai.mit.edu> + + * randinex.scm: moved (schmooz) documentation here from scm.texi. + (random:uniform1): Renamed from random:uniform. + (random:uniform): Added (takes optional state argument). + (random:normal): Made reentrant. + + * random.scm: moved (schmooz) documentation here from scm.texi. + +1999-01-09 Aubrey Jaffer <jaffer@ai.mit.edu> + + * random.scm (seed->random-state): added. + +1999-01-08 Aubrey Jaffer <jaffer@ai.mit.edu> + + * mitscheme.init (object->limited-string): Added. + + * random.scm (random:random): Fixed embarrassingly stupid bug. + +1999-01-07 Aubrey Jaffer <jaffer@ai.mit.edu> + + * alistab.scm (supported-key-type?): number now allowed. + +1998-12-22 Radey Shouman <Radey_Shouman@splashtech.com> + + * printf.scm (stdio:round-string): Makes sure result has at least + STRIP-0S characters after the implied decimal point if STRIP-0S is + not false. Fixes bug associated with engineering notation in SCM. + +1998-12-18 Aubrey Jaffer <jaffer@ai.mit.edu> + + * schmooz.scm (schmooz): Converted from replace-suffix to + filename:substitute??. + +1998-12-16 Radey Shouman <Radey_Shouman@splashtech.com> + + * glob.scm (glob:make-substituter): Made to handle cases where + PATTERN and TEMPLATE have different numbers of literal sections. + + * glob.scm (glob:pattern->tokens): (glob:make-matcher): + (glob:make-substituter): Fixed to accept null strings as literals + to match, for REPLACE-SUFFIX. There is no way to write a glob + pattern that produces such a token, should there be? + +1998-12-15 Radey Shouman <Radey_Shouman@splashtech.com> + + * glob.scm (glob:substitute??) renamed from glob:transform?? + (filename:substitute??) identical to glob:substitute?? + +1998-12-14 Radey Shouman <Radey_Shouman@splashtech.com> + + * glob.scm (glob:pattern->tokens): Separated from + GLOB:MAKE-MATCHER. + (glob:make-transformer): + (glob:transform??): + (glob:transform-ci??): Added. + (replace-suffix): Rewritten using GLOB:TRANSFORM?? + +1998-12-09 Aubrey Jaffer <jaffer@ai.mit.edu> + + * yasyn.scm: Restored to SLIB. yasos.scm removed. + * object.scm: Restored to SLIB + * recobj.scm: Restored to SLIB + +1998-12-08 Aubrey Jaffer <jaffer@ai.mit.edu> + + * slib.texi (Copyrights): Added HTML anchor for Copying information. + (Installation): Added HTML anchor for Installation instructions. + +1998-12-02 Aubrey Jaffer <jaffer@ai.mit.edu> + + * fluidlet.scm (fluid-let): Rewritten as defmacro. + +1998-11-30 Radey Shouman <Radey_Shouman@splashtech.com> + + * fluidlet.scm (fluid-let): Changed macro definition so that it + doesn't depend on being able to combine input from two different + ellipsis patterns. Now produces a nice expansion with + macro-by-example so that one can see exactly what goes wrong. + +1998-11-29 Aubrey Jaffer <jaffer@ai.mit.edu> + + * htmlform.scm (table->html): Table conversion functions added. + +1998-11-27 Aubrey Jaffer <jaffer@ai.mit.edu> + + * nclients.scm (glob-pattern?): Added. + +1998-11-24 Aubrey Jaffer <jaffer@ai.mit.edu> + + * htmlform.scm (html:href-heading): simplified. + +1998-11-16 Aubrey Jaffer <jaffer@ai.mit.edu> + + * htmlform.scm (html:comment): No longer puts `>' alone on line. + (make-plain make-atval): renamed from html:plain and html:atval; + html: functions now all output HTML. + + * nclients.scm (user-email-address): Ported to W95 and WNT. + (make-directory): added. + + * dbrowse.scm (browse:display-table): Column-foreigns restored. + + * htmlform.scm (html:atval html:plain): Now accept numbers. + (html:pre): Added. + (html:start-page html:end-page): Updated to HTML 3.2. HTML header + added. + + * rdms.scm (make-relational-system): column-foreign-list split + into column-foreign-check-list and column-foreign-list. + +1998-11-12 Aubrey Jaffer <jaffer@ai.mit.edu> + + * lineio.scm (display-file): added. Schmoozed docs. + +1998-11-12 Radey Shouman <Radey_Shouman@splashtech.com> + + * schmooz.scm (schmooz-top): No longer emits @defun lines for + definitions not separated by blank lines unless they have + associated @body comment lines. + +1998-11-11 Radey Shouman <Radey_Shouman@splashtech.com> + + * fluidlet.scm (fluid-let): Redone to restore variable values even + if a continuation captured in the body is invoked. Now agrees + with MIT Scheme documentation. + +1998-11-11 Aubrey Jaffer <jaffer@ai.mit.edu> + + * nclients.scm: Added net-clients. + + * require.scm (vicinity:suffix?): Abstracted from + program-vicinity. + +1998-11-04 Aubrey Jaffer <jaffer@ai.mit.edu> + + * comlist.scm (remove-duplicates): added. + (adjoin): memq -> memv. + +Tue Nov 3 17:47:32 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net> + + * require.scm (*SLIB-VERSION*): Bumped from 2c3 to 2c4. + +1998-10-24 Aubrey Jaffer <jaffer@ai.mit.edu> + + * cring.scm: Added procedures to create and manipulate rulesets. + + * cring.scm (cring:db): Distributing / over + led to infinite + loops. Now only distribute *. + +1998-10-19 amu@mit.edu + + * timezone.scm (tzfile:vicinity): Linux RH 5.x moved zoneinfo to + /usr/share and didn't bother to leave a symlink behind. This + caused ctime to print out things in GMT, instead of using the + local time. + +1998-10-01 Aubrey Jaffer <jaffer@ai.mit.edu> + + * factor.scm: Moved documentation to schmooz format. + (prime:prime< prime:prime>): written. + (prime:prngs): added. + (Solovay-Strassen??): No longer tries `1'. + (prime:products): Added list of prime products smaller than + most-positive-fixnum. + (prime:sieve): added to test for primes smaller than largest prime + in prime:products. + (prime:factor): wrapper rewritten. Code cleaned up. + + * primes.scm: removed. + +1998-09-29 Aubrey Jaffer <jaffer@ai.mit.edu> + + * paramlst.scm (check-parameters): Now generates slib:warn when + parameter is wrong type. + + * debug.scm (for-each-top-level-definition-in-file): Now discards + `magic-number' first line of files when first character is `#'. + + * batch.scm (batch:port parms): enabled warning. + +1998-09-28 Aubrey Jaffer <jaffer@ai.mit.edu> + + * scheme2c.init scsh.init t3.init chez.init, vscm.init, + scheme48.init, mitscheme.init, macscheme.init, gambit.init, + elk.init, Template.scm: Placed in public domain to make + distributing modified versions easier. + + * schmooz.scm, htmlform.scm, admin.scm, glob.scm, ChangeLog: + Cleaned a bit. + +1998-09-28 Aubrey Jaffer <jaffer@ai.mit.edu> + + * slib.texi (most-positive-fixnum): fixed description. + +1998-09-22 Ortwin Gasper <gasper@sensecom.de> + + * random.scm (random:random): Removed one-parameter call to + logand. + +1998-09-22 Radey Shouman <Radey_Shouman@splashtech.com> + + * schmooz.scm: Changed all references to #\nl to #\newline. + Removed all references to #\cr. Trailing whitespace no longer + prevents issuing a defunx for an additional definition form. + +1998-09-21 Aubrey Jaffer <jaffer@ai.mit.edu> + + * primes.scm: Eliminated use of 1+. + (probably-prime?): #f for negative numbers. + +1998-09-19 Jorgen Schaefer <forcer@mindless.com> + + * glob.scm (glob:match?? glob:match-ci??): fixed wrappers. + +1998-09-11 Aubrey Jaffer <jaffer@colorage.com> + + * Makefile (release): Uploads SLIB.html. + + * require.scm (*SLIB-VERSION*): Bumped from 2c2 to 2c3. + + * slib.texi (Filenames): documented pattern strings. + + * Makefile: Added $srcdir to TEXINPUTS for TeX. + +1998-09-10 Radey Shouman <Radey_Shouman@splashtech.com> + + * schmooz.scm (schmooz): Added @args markup command. + +1998-09-09 Radey Shouman <Radey_Shouman@splashtech.com> + + * schmooz.scm (schmooz): Now tries harder to determine whether a + definition is of a procedure or non-procedure variable. + Recognizes DEFMACRO, DEFINE-SYNTAX. + +1998-09-06 Aubrey Jaffer <jaffer@ai.mit.edu> + + * slib.texi (Schmooz): Added documentation. + + * Makefile (info htmlform.txi): made smarter about when to run + schmooz. + +1998-09-03 Radey Shouman <Radey_Shouman@splashtech.com> + + * schmooz.scm (scheme-args->macros): Now passed either a symbol, + for variable definition, or a possibly improper list, for + function/macro definition. For the variable definition case + generates @var{... for @0 instead of @code{... Now uses APPEND to + be more readable. + +1998-09-03 Aubrey Jaffer <jaffer@colorage.com> + + * slib.texi (Format): documentation moved to fmtdoc.txi. + + * glob.scm (filename:match?? filename:match-ci??): aliases added. + +1998-09-02 Radey Shouman <Radey_Shouman@splashtech.com> + + * glob.scm: Added. + +1998-09-01 Aubrey Jaffer <jaffer@colorage.com> + + * primes.scm (primes:prngs): added to reduce likelyhood of + reentrant random calls. + +1998-08-31 Aubrey Jaffer <jaffer@ai.mit.edu> + + * random.scm: rewritten using new seedable RNG. + + * randinex.scm (random:uniform): Rewritten for new RNG. + +1998-08-27 Aubrey Jaffer <jaffer@colorage.com> + + * primes.scm (primes:dbsp?): Now requires 'root and uses + integer-sqrt for sqrt on platforms not supporting inexacts. + +1998-08-25 <radey@colorage.com> + + * record.scm (rtd-name): Fixed so record rtds print. + +1998-08-16 Aubrey Jaffer <jaffer@ai.mit.edu> + + * cring.scm (*): Number distribution requires separate treatment. + +1998-08-11 Aubrey Jaffer <jaffer@ai.mit.edu> + + * factor.scm (prime:factor): (factor 0) now returns '(0) rather + than infinite-looping. + +1998-08-09 Aubrey Jaffer <jaffer@ai.mit.edu> + + * cring.scm (*): Added check for (* -1 (- <expr>)) case. + +1998-07-08 Aubrey Jaffer <jaffer@colorage.com> + + * prec.scm (prec:warn): now takes arbitrary number of arguments. + (prec:nofix): + (prec:postfix): extra arguments are appended to the rules list; + not bound. + + * qp.scm (qp:qp): *qp-width* set to #f now the same as *qp-width* + set to 0 -- the full expressions are printed. + +1998-07-05 Aubrey Jaffer <jaffer@ai.mit.edu> + + * prec.scm (prec:nofix): Added . binds args, which are combined + with *syn-rules*. + +1998-06-12 Aubrey Jaffer <jaffer@colorage.com> + + * Makefile (dist): Added cvs flag command to dist target. + +1998-06-08 Aubrey Jaffer <jaffer@colorage.com> + + * htmlform.scm (html:start-form): added rest of METHOD types. + (html:generate-form command->html): regularized argument order to + `command method action'. + + * dbutil.scm (add-domain): Changed from row:insert to row:update. + + * rdms.scm (write-database): was not returning status. + +1998-06-07 Aubrey Jaffer <jaffer@ai.mit.edu> + + * strcase.scm (string-ci->symbol): added. + + * htmlform.scm ((command->html rdb command-table command method + action)): renamed from commands->html. Method argument added. + (query-alist->parameter-list): now removes whitespace between + symbols. + +Fri Jun 5 16:01:26 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> + + * require.scm (*SLIB-VERSION*): Bumped from 2c1 to 2c2. + +1998-06-04 Aubrey Jaffer <jaffer@colorage.com> + + * schmooz.scm: Top-level procedure names changed to have `schmooz' + in them. + + * htmlform.scm: Schmooz documentation added for more procedures. + +1998-06-03 Aubrey Jaffer <jaffer@ai.mit.edu> + + * schmooz.scm (document-args->macros): fixed for `rest arglists'. + (document-fun): fixed for `rest arglists'. + + * strsrch.scm (string-subst): added. + + * htmlform.scm (html:text-subst): removed. References changed to + STRING-SUBST. + +1998-06-02 radey <radey@scm.colorage.net> + + * Makefile: Added schmooz.scm to ffiles. + + * schmooz.scm: Texinfo document generator for Scheme programs. + +1998-06-02 Aubrey Jaffer <jaffer@colorage.com> + + * htmlform.scm: Added documentation. + (http:send-error-page): scope of fluid-let was wrong. + + * paramlst.scm (check-parameters): now returns status rather than + signal error. + +1998-05-30 Aubrey Jaffer <jaffer@ai.mit.edu> + + * batch.scm (write-batch-line): added. + (batch:write-comment-line): added so that + batch:call-with-output-script and batch:comment could share code. + (batch:write-header-comment): abstracted from + batch:call-with-output-script. + +1998-05-29 Aubrey Jaffer <jaffer@colorage.com> + + * htmlform.scm: Added http stuff. + +1998-05-24 Aubrey Jaffer <jaffer@ai.mit.edu> + + * cring.scm (make-rat rat-*): Removed support for rational numbers. + +1998-05-14 Radey Shouman <radey@colorage.com> + + * logical.scm ((bit-field n start end)): Renamed from BIT-EXTRACT. + ((bitwise-if mask n0 n1)): + ((logical:copy-bit index to bool)): + ((logical:copy-bit-field to start end from)): added. + +Tue Apr 14 16:28:20 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net> + + * require.scm (*SLIB-VERSION*): Bumped from 2c0 to 2c1. + +1998-04-14 Aubrey Jaffer <jaffer@colorage.com> + + * byte.scm (bytes-length): added synonym for string-length. + +1998-04-14 <radey@colorage.com> + + * printf.scm ((stdio:iprintf out format-string . args)): Added + %b descriptor -- outputs a binary number representation. + +1998-03-31 <radey@colorage.com> + + * printf.scm ((stdio:iprintf out format-string . args)): Floating point + formatting implemented. + ((stdio:parse-float str)): ((stdio:round-string str ndigs strip-0s)): + Added. + +1998-03-11 Radey Shouman <radey@colorage.com> + + * require.scm (program-vicinity): Now gives more informative error + message when called from non-loading context. + +1998-02-10 William D Clinger <will@ccs.neu.edu> + + * mwexpand.scm (mw:case exp): added. + + * mwdenote.scm (mw:denote-of-case): added. + +1998-02-12 Aubrey Jaffer <jaffer@colorage.com> + + * eval.scm (eval): Dynamic-binding was not the right paradigm. + Changed eval to simply bind identifiers around form to eval. + +1998-02-11 Aubrey Jaffer <jaffer@colorage.com> + + * slib.texi (Top): + (Extra-SLIB Packages): Converted to use of new texinfo feature + @url. + +1998-02-08 Aubrey Jaffer <jaffer@ai.mit.edu> + + * eval.scm (interaction-environment): fixed. + +1998-02-02 Aubrey Jaffer & Radey Shouman <jaffer@ai.mit.edu> + + * eval.scm (scheme-report-environment): implemented for version + arguments of 4 and 5. + +1998-02-01 Aubrey Jaffer <jaffer@ai.mit.edu> + + * eval.scm (eval): R5RS proposed EVAL implemented. + +Sun Dec 7 22:34:50 1997 Aubrey Jaffer <jaffer@ai.mit.edu> + + * getparam.scm (getopt->parameter-list getopt->arglist + parameter-list->getopt-usage): moved from paramlst.scm. + + * htmlform.scm (commands->html cgi:serve-command): added. + +Thu Dec 4 20:00:05 1997 Aubrey Jaffer <jaffer@ai.mit.edu> + + * timezone.scm (read-tzfile): Now can fail without signaling an + error. + (tzfile:vicinity): moved here from "tzfile.scm" so we don't have + to load "tzfile.scm" to load a non-existant file. + +Sat Nov 29 22:55:23 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * paramlst.scm (parameter-list->getopt-usage): split out of + getopt->parameter-list. + +Wed Nov 26 23:49:53 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * printf.scm (stdio:sprintf): Now creates and returns string if + first argument is #f or an integer (which bounds string). Fixed + some bugs. + +Sun Nov 23 12:31:27 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * Bev2slib.scm: created. Converts Stephen Bevan's "*.map" files + to SLIB catalog entries. + + * require.scm (require:require): Calls catalog:get instead of + require:feature->path so symbol-redirected feature names are added + to *features* when file is loaded. + +Mon Nov 17 21:05:59 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * dbrowse.scm (browse): changed default table to #f so that full + *catalog-data* can be browsed. Documented. + +Sat Nov 15 00:15:33 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * cltime.scm (decode-universal-time encode-universal-time): + corrected for (now working) timezones. + + * tzfile.scm (tzfile-read tz-index): added to read Linux (sysV ?) + timezone files. + + * byte.scm: added `bytes', arrays of small integers. + +Thu Nov 13 22:28:15 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * record.scm (display write): Records now display and write as + #<record-type-name>. + +Sun Nov 9 23:45:46 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * timezone.scm: added. Processes TZ environment variable to + timezone information. + (tzset): takes optional string or timezone argument and returns + the current timezone. + (time-zone): creates and returns a timezone from a string filename + or TZ spec *without* setting global variables. + (daylight? *timezone* tzname): Posix (?) global variables are + set but SLIB code doesn't depend on them. + + * psxtime.scm (time:gmktime time:gtime): added to fill out + orthogonal function set. The local time functions (localtime + mktime ctime) now all take optional timezone arguments. + (time:localtime): cleaned interface to timezone.scm: just calls to + tzset and tz:params. + +Mon Oct 20 22:18:16 1997 Radey Shouman <shouman@zianet.com> + + * arraymap.scm (array-index-map!): Added. + (array-indexes): implemented with array-index-map! + +Sun Nov 2 22:59:59 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * require.scm (*SLIB-VERSION*): Bumped from 2b3 to 2c0. + + * require.scm (catalog:get): Now loads "homecat" and "usercat" + catalogs in HOME and current directories. + (catalog/require-version-match?): debugged for dumped executables. + ((require #f)): resets *catalog*. + ((require 'new-catalog)): builds new catalog. + + * mklibcat.scm: Rewrote to output headers and combine + implementation and site specific catalogs into "slibcat". + + * slib.texi (The Library System): Added chapter. Totally + reorganized the Manual. + +Wed Oct 29 22:49:15 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * Template.scm *.init (home-vicinity): added. + + * require.scm (catalog:try-read): split off from + catalog:try-impl-read; useful for reading catalogs from other + vicinities. + +Thu Oct 23 23:14:33 1997 Eric Marsden <marsden@salines.cict.fr> + + * factor.scm (prime:product): added EXACT? test. + +Mon Oct 20 19:33:41 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * slib.texi (Database Utilities): Rewrote and expanded + command-line parser example. + + * paramlst.scm (getopt->parameter-list): Added "Usage" printer + for strange option chars. + + * comlist.scm (coerce): Added 'integer as an alias for 'number. + +Sat Oct 18 13:03:24 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * strsrch.scm (string-index-ci string-reverse-index-ci + substring-ci): added. + + * comlist.scm (comlist:butnthcdr): added by analogy with butlast. + +Sun Oct 5 15:16:17 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * scsh.init: Added (thanks to Tomas By). + +Fri Oct 3 20:50:32 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * comparse.scm (read-command): now correctly handles \^M^J + (continued lines). + (read-options-file): added. Parses multi-line files of options. + +Fri Sep 19 22:52:15 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * paramlst.scm (fill-empty-parameters getopt->arglist): defaults + argument renamed to defaulters; documentation corrected. + +Tue Aug 26 17:41:39 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * batch.scm: Changed sun to sunos as platform name. + +Mon Aug 25 12:40:45 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * require.scm (catalog:version-match?): Now checks and issues + warning when *SLIB-VERSION* doesn't match first form in + "require.scm". + +Sun Aug 24 23:56:07 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * require.scm (catalog:version-match?): added to automatically + rebuild slibcat when SLIB with new version number is installed. + + * mklibcat.scm: *SLIB-VERSION* association now included in + slibcat. + +Sat Aug 23 11:35:20 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * selfset.scm: added. (define a 'a) .. (define z 'z). + +Sat Aug 23 09:32:44 EDT 1997 Aubrey Jaffer <jaffer@ai.mit.edu> + + * require.scm (*SLIB-VERSION*): Bumped from 2b2 to 2b3. + +Thu Aug 21 10:20:21 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * determ.scm (determinant): added. + +Mon Jun 30 10:09:48 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * require.scm: "Supported by all implementations" section removed. + + * chez.init (defmacro:eval): Chez 5.0 no longer can support + defmacro; added SLIB autoload defmacro:expand*. + +Sun Jun 29 19:36:34 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * cring.scm (cring:db): cring now works for -, /, and ^. + +Thu Jun 26 00:19:05 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * cring.scm (expression-< x y): added to sort unreduced + expressions. + +Tue Jun 24 13:33:40 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * cring.scm: Added 'commutative-ring feature; extend + and * to + non-numeric types. + (cring:define-rule): Defines rules for + and * reduction of + non-numeric types. + +Mon Jun 23 22:58:44 EDT 1997 Aubrey Jaffer <jaffer@scm.bertronics.com> + + * require.scm (*SLIB-VERSION*): Bumped from 2b1 to 2b2. + +Sat Jun 21 23:20:29 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * alistab.scm (map-key for-each-key ordered-for-each-key): Now + take match-key argument. + (delete*): added. delete-assoc created to *not* accept wildcards + in delete keys. + + * rdms.scm (get* row:delete* row:remove*): Now take match-key + arguments, normalize them, and pass to base-table routines. + +Thu Jun 19 13:34:36 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * alistab.scm (assoc* make-assoc* delete-assoc* assoc*-for-each + assoc*-map sorted-assoc*-for-each alist-sort!): added. Functions + now support partial matches and key wild-carding. + (remover kill-table): remover removed. Kill-table uses + delete-assoc*. + +Sat Jun 14 22:51:51 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * alistab.scm (alist-table): Changed table handle from + (table-name . TABLE) to (#(table-name key-dim) . TABLE). + (alist-table): Changed primary keys from vectors to lists. + +Wed 28 May 1997 Dave Love <d.love@dl.ac.uk> + + * yasos.scm: Remove case-sensitivity (for Guile). Chop the + duplicated code. + +Mon May 26 21:46:45 1997 Bill Nell <bnell@scr.siemens.com> + + * strport.scm (call-with-output-string): losing every 512th + character fixed. + +Wed May 21 19:16:03 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * printf.scm (stdio:iprintf): changed integer-pad to + integer-convert and unified conversion of non-numeric values. + +Wed May 14 14:01:02 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * prec.scm (prec:symbolfy): added so that for most user grammar + functions, parsing defaults to the triggering token, instead of + the symbol @code{?}. + +Tue May 13 22:46:22 1997 Albert L. Ting <alt@artisan.com> + + * elk.init (slib:error): re-written. + +Sat May 10 22:00:30 EDT 1997 Aubrey Jaffer <jaffer@scm.bertronics.com> + + * require.scm (*SLIB-VERSION*): Bumped from 2b0 to 2b1. + +Wed May 7 15:11:12 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * prec.scm: Rewrote nearly all of JACAL parser and moved it here. + Now supports dynamic binding of grammar. + +Tue May 6 16:23:10 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * strsrch.scm (find-string-from-port?): Enhanced: can take char + instead of count and search up to char. Given procedure, tests it + on every character. + +Wed 30 Apr 1997 John David Stone <stone@math.GRIN.EDU> + + * chez.init: Revised for Chez Scheme 5.0c + +Tue Apr 29 19:55:35 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * require.scm (*SLIB-VERSION*): Bumped from 2a7 to 2b0. + + * slib.texi (Library Catalog): section added to describe new + catalog mechanism. + + * Makefile (slib48): Now defines library-vicinity and + implementation-vicinity from the makefile. "slibcat" support + added. + +Sat Apr 12 23:40:14 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * mklibcat.scm: moved from "require.scm". Rebuilds "slibcat". + * require.scm (catalog:get): now caches *catalog* in + implementation-vicinity scheme files "slibcat" and "implcat". + +Wed Apr 9 20:55:31 1997 Dorai Sitaram <ds26@gte.com> + + * mbe.scm (hyg:map*): Added to correct a minor bug in the hygienic + half of mbe.scm that shows up only when define-syntax is used in a + right-hand pattern inside syntax-rules. + + * strsrch.scm (string-reverse-index): added. + +Tue Apr 8 16:46:35 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * yasos.scm: Replaces "yasyn.scm" and "object.scm"; Those and + "recobj.scm" were removed because of unclear copyright status. + + * printf.scm (stdio:iprintf): no longer translates \r to #\return. + +Sat Aug 10 16:11:15 1996 Mike Sperber <sperber@informatik.uni-tuebingen.de> + + * scheme48.init Makefile: Now makes use of module system to access + required primitives. Added install48 target to Makefile. + +Sat Apr 5 13:26:54 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * array.scm (array-dimensions): fixed off-by-1 bug. + +Sat Mar 8 17:44:34 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * scanf.scm (stdio:scan-and-set): corrected handling of %5c with + short input. + +Fri Mar 7 21:20:57 EST 1997 Aubrey Jaffer <jaffer@scm.bertronics.com> + + * require.scm (*SLIB-VERSION*): Bumped from 2a6 to 2a7. + +Sat Feb 22 10:18:36 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * batch.scm (system): added stubifier (returns #f) for when + system is not provided. + (system:success?): added. + + * wttree.scm (error): + (error:wrong-type-argument): + (error:bad-range-argument): Stubs added for non-MITScheme + implementations. + + * Template.scm *.init (slib:warn): added. + +Sun Feb 16 21:55:59 1997 Michael Pope <michael.pope@dsto.defence.GOV.AU> + + * gambit.init (scheme-implementation-version): updated for Gambit + v2.4. + +Sun Dec 1 00:44:30 1996 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * batch.scm (truncate-up-to): Added to support compiler habbit of + putting object files in current-directory. + +Sat Aug 31 12:17:30 1996 Aubrey Jaffer <jaffer@martigny.bertronics> + + * scm.init: added for completeness + + * record.scm (vector?): infinite recursion fixed. + + * dbutil.scm (make-command-server): Documentation updated. + +Wed Aug 21 20:38:26 1996 John Gerard Malecki <johnm@vlibs.com> + + * vscm.init: Implements string ports using `generic ports'. + +Wed Aug 21 20:38:26 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * record.scm: rewritten to make records disjoint types + which are unforgable and uncorruptable by R4RS procedures. + +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@acm.org (Oleg Kiselyov). + +Sat Feb 3 00:02:06 1996 Oleg Kiselyov (oleg@acm.org) + + * strsrch.scm (string-index substring? find-string-from-port?): added. + +Mon Jan 29 23:56:33 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * printf.scm (stdio:iprintf): Rewrote for Posix compliance (+ + extensions which are both BSD and GNU). + +Sat Jan 27 09:55:03 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * FAQ: printf vs. format explained. + + * printf.scm: renamed from "stdio.scm". (require 'printf) now + brings in "printf.scm". + +Sun Jan 14 21:00:17 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * scanf.scm: Rewrote from scratch. + +Mon Oct 9 22:48:58 1995 Aubrey Jaffer (jaffer@jacal) + + * modular.scm (modular:invertable?): added. + +Wed Sep 27 10:01:04 1995 Aubrey Jaffer (jaffer@jacal) + + * debug.scm: augmented, reorganized, and split. + (print): removed. + + * break.scm: created. + + * qp.scm: created. + +Sun Sep 24 22:23:19 1995 Aubrey Jaffer (jaffer@jacal) + + * require.scm (*catalog*): test.scm removed. + +Sun Sep 17 21:32:02 1995 Aubrey Jaffer (jaffer@jacal) + + * modular.scm: rewritten so that if modulus is: + positive? -- work as before (Z_modulus) + zero? -- perform integer operations (Z) + negative? -- perform operations using symmetric + representation (Z_(1-2*modulus)) + (symmetric:modulus modulus->integer modular:normalize): added. + (modular:*): not completed for fixnum-only implementations. + +Sat Sep 9 16:53:22 1995 Aubrey Jaffer (jaffer@jacal) + + * slib.texi (Legacy): added for t, nil, last-pair, and identity, + which are now required of all implementations. + +Mon Aug 28 00:42:29 1995 Aubrey Jaffer (jaffer@jacal) + + * require.scm (require:feature->path require:provided? + require:require): cleaned up. feature->path now returns a path, + whether the module is loaded or not. + +Sun Aug 27 11:05:19 1995 Aubrey Jaffer (jaffer@jacal) + + * genwrite.scm (generic-write): Fixed "obj2str" + OBJECT->LIMITED-STRING non-terminating wr-lst for cases like + (set-car! foo foo). + + * obj2str.scm (object->limited-string): uncommented. + +Sun Aug 20 17:10:40 1995 Stephen Adams <adams@martigny.ai.mit.edu> + + * wttest.scm wttree.scm: Weight Balanced Trees added. + +Sun Aug 20 16:06:20 1995 Dave Love <d.love@dl.ac.uk> + + * tree.scm yasyn.scm collect.scm: Uppercase identifiers changed to + lower case for compatability with case sensitive implementations. + +Sat Aug 19 21:27:55 1995 Aubrey Jaffer (jaffer@jacal) + + * arraymap.scm (array-copy!): added. + + * primes.scm (primes:primes< primes:primes>): primes:primes split + into ascending and descending versions. + +Sun Jul 16 22:44:36 1995 Aubrey Jaffer (jaffer@jacal) + + * makcrc.scm (make-port-crc): added. POSIX.2 checksums. + +Mon Jun 12 16:20:54 1995 Aubrey Jaffer (jaffer@jacal) + + * synclo.scm (internal-syntactic-environment + top-level-syntactic-environment): replaced call to alist-copy. + + * require.scm (*catalog*): 'schelog, 'primes, and 'batch added. + 'prime renamed to 'factor. + + From: mhc@edsdrd.eds.com (Michael H Coffin) + * primes.scm (primes probably-prime?): added. prime.scm renamed + to factor.scm. + +Fri Mar 24 23:35:25 1995 Matthew McDonald <mafm@cs.uwa.edu.au> + + * struct.scm (define-record): added field-setters. + +Sun Jun 11 23:36:55 1995 Aubrey Jaffer (jaffer@jacal) + + * batch.scm: added + + * Makefile (schelogfiles): SLIB schelog distribution created. + +Mon Apr 17 15:57:32 1995 Aubrey Jaffer (jaffer@jacal) + + * comlist.scm (coerce type-of): added. + + * debug.scm (debug:qp): with *qp-width* of 0 just `write's. + + * paramlst.scm (getopt->parameter-list): Now accepts long-named + options. Now COERCEs according to types. + +Sat Apr 15 23:15:26 1995 Aubrey Jaffer (jaffer@jacal) + + * require.scm (require:feature->path): Returns #f instead of + string if feature not in *catalog* or *modules*. + +Sun Mar 19 22:26:52 1995 Aubrey Jaffer (jaffer@jacal) + + * getopt.scm (getopt-- argc argv optstring): added wrapper for + getopt which parses long-named-options. + +Tue Feb 28 21:12:14 1995 Aubrey Jaffer (jaffer@jacal) + + * paramlst.scm (parameter-list-expand expanders parms): added. + +Mon Feb 27 17:23:54 1995 Aubrey Jaffer (jaffer@jacal) + + * report.scm (dbutil:print-report): added. + + * comparse.scm (read-command): added. Reads from a port and + returns a list of strings: the arguments (and options). + +Sat Feb 25 01:05:25 1995 Aubrey Jaffer (jaffer@jacal) + + * repl.scm (repl:repl): Added loop, conditional on CHAR-READY? + being PROVIDED?, which reads through trailing white-space. + +Sun Feb 5 16:34:03 1995 Aubrey Jaffer (jaffer@jacal) + + * paramlst.scm ((make-parameter-list parameter-names)): + ((fill-empty-parameters defaults parameter-list)): + ((check-parameters checks parameter-list)): + ((parameter-list->arglist positions arities parameter-list)): + ((parameter-list-ref parameter-list i)): + ((adjoin-parameters! parameter-list parameters)): + Procedures for making, merging, defaulting, checking and + converting `parameter lists' (named parameters). + ((getopt->parameter-list argc argv optnames arities aliases)): + ((getopt->arglist argc argv optnames positions + arities defaults checks aliases)): + Procedures for converting options and arguments processed by + getopt to parameter-list or arglist form. + + * dbutil.scm ((make-command-server rdb command-table)): added + procedure which calls commands and processes parameters. + + * rdms.scm ((make-relational-system base)): add-domain and + delete-domain commands moved to "dbutil.scm" (create-database). + +Fri Feb 3 11:07:46 1995 Aubrey Jaffer (jaffer@jacal) + + * debug.scm (debug:tracef debug:untracef): removed (duplicates of + code in "trace.scm"). + (trace-all): utility to trace all defines in a file added. + +Thu Jan 19 00:26:14 1995 Aubrey Jaffer (jaffer@jacal) + + * logical.scm (logbit? logtest): added. + +Sun Jan 15 20:38:42 1995 Aubrey Jaffer (jaffer@jacal) + + * dbutil.scm (dbutil:create-database)): Added parameter + description tables for "commands". + + * require.scm (software-type): standardize msdos -> ms-dos. + +Mon Jan 2 10:26:45 1995 Aubrey Jaffer (jaffer@jacal) + + * comlist.scm (comlist:atom?): renamed from comlist:atom. + + * scheme48.init (char->integer integer->char): Now use integers in + the range 0 to 255. Fixed several other problems. + (modulo): Worked around negative modulo bug. + + * Makefile (slib48): `make slib48' loads "scheme48.init", `,dump's + a scheme48 image file, and creates an `slib48' shell script to + invoke it. + + * hash.scm (hash:hash-number): no longer does inexact->exact to + exacts, etc. + + * trnscrpt.scm (read): no longer transcripts eof-objects. + + From: johnm@vlibs.com (John Gerard Malecki) + * priorque.scm (heap:heapify): internal defines incorrectly + dependent on order-of-eval replaced with let*. + +Thu Dec 22 13:28:16 1994 Aubrey Jaffer (jaffer@jacal) + + * dbutil.scm (open-database! open-database create-database): This + enhancement wraps a utility layer on `relational-database' which + provides: + * Automatic loading of the appropriate base-table package when + opening a database. + * Automatic execution of initialization commands stored in + database. + * Transparent execution of database commands stored in + `*commands*' table in database. + +Wed Dec 21 22:53:57 1994 Aubrey Jaffer (jaffer@jacal) + + * rdms.scm (make-relational-system base): Now more careful about + protecting read-only databases. + +Mon Dec 19 00:06:36 1994 Aubrey Jaffer (jaffer@jacal) + + * dbutil.scm (dbutil:define-tables): added utility which provides: + Data definition from Scheme lists for any SLIB + relational-database. + +Sat Dec 17 12:10:02 1994 Aubrey Jaffer (jaffer@jacal) + + * alistab.scm rdms.scm (make-getter row-eval): evaluation of + `expression' fields no longer done when retrieved from base + tables (which made copying of many tables impossible). + + * alistab.scm + (write-base): rewrote to not use pretty-print. + + * sc3.scm: removed (only contained last-pair, t, and nil). + + * Template.scm scheme48.init vscm.init (last-pair t nil): added. + +Thu Dec 8 00:02:18 1994 Aubrey Jaffer (jaffer@jacal) + + * mularg.scm pp.scm ratize.scm: copyright line removed from files + (still lacking terms) less than 12 lines. + + From: johnm@vlibs.com (John Gerard Malecki) + * sort.scm (sort:sort!): long standing bug in sort! with vector + argument fixed. + +Thu Dec 1 17:10:24 1994 Aubrey Jaffer (jaffer@jacal) + + * *.scm: Most missing copyright notices supplied. + +Sun Nov 27 23:57:41 1994 Aubrey Jaffer (jaffer@jacal) + + * rdms.scm (make-relational-system base): now checks field types + when table is opened. Domains table now has foreign-table field. + (for-each-row): ordered for-each function added. + * alistab.scm (ordered-for-each-key supported-key-type?): added. + +Thu Oct 27 12:20:41 1994 Tom Tromey <tromey@drip.colorado.edu> + + * priorque.scm: Renamed everything to conform to coding standards + and updated docs. Changed names: heap-extract-max to + heap-extract-max!, heap-insert to heap-insert! and heap-size to + heap-length. + +Sat Nov 26 22:52:31 1994 Aubrey Jaffer (jaffer@jacal) + + * Template.scm *.init (identity): Now required; moved from + "comlist.scm". + + * alistab.scm (alist-table): Converted to representing rows as + lists. Non-row operations removed. + + * rdms.scm (make-relational-system base): Most individual column + operations removed. Only get and get* remain. Row operations + renamed. Row inserts and updates distinguished. + +Tue Nov 15 16:37:16 1994 Aubrey Jaffer (jaffer@jacal) + + * rdms.scm (make-relational-system base): Generalized database + system inspired by the Relational Model. + + * alistab.scm (alist-table): Base table implementation suitable + for small databases and testing rdms.scm. + +Tue Oct 25 22:36:01 1994 Aubrey Jaffer (jaffer@jacal) + + From: Tommy Thorn <Tommy.Thorn@irisa.fr> + * chez.init (scheme-implementation-version): fixed (changed to "?"). + (library-vicinity): The definition of library-vicinity used + getenv, which was defined later. + (slib:chez:quit): The definition of slib:chez:quit was illegal. + Fixed. + (chez:merge!): had a typo. + (defmacro:load): (require 'struct) didn't work, because defmacro:load + doesn't add suffix. Workaround: defmacro:load and macro:load is + the same as slib:load-source. + +Wed Oct 19 11:44:12 1994 Aubrey Jaffer (jaffer@jacal) + + * require.scm time.scm cltime.scm (difftime offset-time): added to + allow 'posix-time functions to work with a non-numeric type + returned by (current-time). + +Tue Aug 2 10:44:32 1994 Aubrey Jaffer (jaffer@jacal) + + * repl.scm (repl:top-level repl:repl): Multiple values at top + level now print nicely. + +Sun Jul 31 21:39:54 1994 Aubrey Jaffer (jaffer@jacal) + + * cltime.scm (get-decoded-time get-universal-time + decode-universal-time encode-universal-time): + Common-Lisp time conversion routines created. + + * time.scm (*timezone* tzset gmtime localtime mktime asctime ctime): + Posix time conversion routines created. + +Mon Jul 11 14:16:44 1994 Aubrey Jaffer (jaffer@jacal) + + * Template.scm mitscheme.init scheme2c.init t3.init (*features*): + trace added. + +Fri Jul 8 11:02:34 1994 Aubrey Jaffer (jaffer@jacal) + + * chap.scm ((chap:string<? s1 s2) (chap:next-string s)): Functions + for "chapter ordering" of strings. + +Mon Jun 20 22:36:44 1994 Aubrey Jaffer (jaffer@jacal) + + * slib.texi (R4RS Macros section): added. + + From: jjb@isye.gatech.edu (John Bartholdi) + * sierpinski.scm (MAKE-SIERPINSKI-INDEXER): added. + * soundex.scm (SOUNDEX): added. + + From: hugh@cosc.canterbury.ac.nz (Hugh Emberson) + * mwexpand.scm ((mw:quasiquote exp env)): Fixed bug which occured + when mw:quasiquote expanded things like `(1 2 3 . ,(+ 1 a)). I + added support for vectors in quasiquotes while I was there. + +Sun Jun 19 00:37:09 1994 Aubrey Jaffer (jaffer@jacal) + + * defmacex.scm ((defmacro:expand* e)): fixed problem with varargs + define. + +Sat Jun 18 13:08:33 1994 Aubrey Jaffer (jaffer@jacal) + + * randinex.scm ((random:size-float l x)): no longer assumes that + inexact numbers have finite precision, which is not necessarily + true (pointed out by jar@ai.mit.edu). Limits size to 4. + +Mon Jun 6 00:46:48 1994 Aubrey Jaffer (jaffer@jacal) + + * trace.scm (trace untrace): created. + (debug:tracef debug:untracef): moved from debug.scm + +Sun May 22 23:44:03 1994 Aubrey Jaffer (jaffer@jacal) + + * yasyn.scm: replaces yasos.scm + +Sat May 21 22:28:01 1994 Aubrey Jaffer (jaffer@jacal) + + * comlist.scm ((comlist:has-duplicates? lst)): added. + +Mon May 16 13:40:18 1994 Aubrey Jaffer (jaffer@jacal) + + From: jjb@isye.gatech.edu (John Bartholdi) + * macscheme.init (slib:exit): fixed. Version set to 4.2. + +Wed Apr 27 00:48:54 1994 Aubrey Jaffer (jaffer@jacal) + + From: jjb@isye.gatech.edu (John Bartholdi) + * scanf.scm (scanf fscanf sscanf): created. + +Thu Apr 14 12:59:41 1994 Aubrey Jaffer (jaffer@jacal) + + From: pegelow@moorea.uni-muenster.de (Ulrich Pegelow) + * mbe.scm (hyg:tag-do): Scoping was wrong. The region of binding + of a <variable> did not include the <step> expression and the + <test> expression, instead it incorrectly included the <init> + expression. (rf. R4RS, 4.2.4) + (hyg:tag-lambda): the body of a lambda expression should be + generated using hyg:tag-generic instead of hyg:tag-vanilla. This + allows expressions within lambda to behave hygienically. + (hyg:tag-let): extended to support `named let'. + +Sun Apr 10 00:22:04 1994 Aubrey Jaffer (jaffer@jacal) + + * README: INSTALLATION INSTRUCTIONS greatly improved. + * Template.scm *.init: Path configurations move to top of files + for easier installation. + + * FAQ: File of Frequently Asked Questions and answers added. + +Sat Apr 9 21:28:46 1994 Aubrey Jaffer (jaffer@jacal) + + * slib.texi (Vicinity): scheme-file-suffix removed. Use + slib:load or slib:load-source instead. + +Wed Apr 6 00:55:16 1994 Aubrey Jaffer (jaffer@jacal) + + * require.scm (slib:report): + (slib:report-version): + (slib:report-locations): added to display SLIB configuration + information. + +Mon Apr 4 08:48:37 1994 Aubrey Jaffer (jaffer@jacal) + + * Template.scm *.init (slib:exit): added. + +Fri Apr 1 14:36:46 1994 Aubrey Jaffer (jaffer@jacal) + + * Makefile (intro): Added idiot message for those who make. + Cleaned up and reorganized Makefile. + +Wed Mar 30 00:28:30 1994 Aubrey Jaffer (jaffer@jacal) + + * Template.scm *.init ((slib:eval-load <pathname> evl)): created + to service all macro loads. + + From: whumeniu@datap.ca (Wade Humeniuk) + * recobj.scm yasyn.scm: added. These implement RECORDS and + YASOS using object.scm object system. + +Sun Mar 6 01:10:53 1994 Aubrey Jaffer (jaffer@jacal) + + From: barnett@armadillo.urich.edu (Lewis Barnett) + * gambit.init (implementation-vicinity library-vicinity): Relative + pathnames for Slib in MacGambit. + + From: lucier@math.purdue.edu (Brad Lucier) + * random.scm (random:random random:chunks/float): fixed off-by-one + and slop errors. + +Thu Mar 3 23:06:41 1994 Aubrey Jaffer (jaffer@jacal) + + From: lutzeb@cs.tu-berlin.de (Dirk Lutzebaeck) + * format.scm slib.texi: Format 3.0. + * format's configuration is rearranged to fit only into SLIB. All + implementation dependent configurations are done in the SLIB init files + * format's output routines rely on call-with-output-string now if + output to a string is desired + * The floating point formatting code (formatfl.scm) moved into + format.scm so that there is only one source code file; this + eliminates the configuration of the load path for the former + formatfl.scm and the unspecified scope of the load primitive + * floating point formatting doesn't use any floating point operation or + procedure except number->string now; all formatting is now based + solely on string, character and integer manipulations + * major rewrite of the floating point formatting code; use global + buffers now + * ~f,~e,~g, ~$ may use also number strings as an argument + * ~r, ~:r, ~@r, ~:@r roman numeral, and ordinal and cardinal + English number printing added (from dorai@cs.rice.edu) + * ~a has now a working `colinc' parameter + * ~t tabulate directive implemented + * ~/ gives a tabulator character now (was ~T in version < 2.4) + * ~& fresh line directive implemented + * ~@d, ~@b, ~@o and ~@x now has the CL meaning (plus sign printed) + automatic prefixing of radix representation is removed + * ~i prints complex numbers as ~f~@fi with passed parameters + * ~:c prints control characters like emacs (eg. ^C) and 8bit characters + as an octal number + * ~q gives information and copyright notice on this format implementation + ~:q gives format:version + * case type of symbol conversion can now be forced (see + format:symbol-case-conv in format.scm) + * case type of the representation of internal objects can now be + forced (see format:iobj-case-conv format.scm) + * format error messages are now printed on the current error port + if available by the implementation + * format now accepts a number as a destination port; the output + is then always directed to the current error port if available by + the implementation + * if format's destination is a string it is regarded as a format string now + and output is the current output port; this is a contribution to + Scheme->C to use format with the runtime system; the former semantics + to append tothe destination string is given up + * obj->string syntax change and speedup + * tested with scm4d, Elk 2.2, MIT Scheme 7.1, Scheme->C 01Nov91 + + +Wed Mar 2 13:16:37 1994 Aubrey Jaffer (jaffer@jacal) + + From: Matthias Blume <blume@cs.Princeton.EDU> + * vscm.init: added. + +Fri Feb 18 23:51:41 1994 Aubrey Jaffer (jaffer@jacal) + + From: jjb@isye.gatech.edu (John Bartholdi) + * macscheme.init: added. + +Thu Feb 17 01:19:47 1994 Aubrey Jaffer (jaffer@jacal) + + * ppfile.scm ((pprint-filter-file inport filter outport)): added. + Useful for pre-expanding macros. Preserves top-level comments. + +Wed Feb 16 12:44:34 1994 Aubrey Jaffer (jaffer@jacal) + + From: dorai@cs.rice.edu (Dorai Sitaram) + * mbe.scm: Macro by Example define-syntax using defmacro. + +Tue Feb 15 17:18:56 1994 Aubrey Jaffer (jaffer@jacal) + + From: whumeniu@datap.ca (Wade Humeniuk) + * object.scm: Macroless Object System + +Mon Feb 14 00:48:18 1994 Aubrey Jaffer (jaffer@jacal) + + * defmacex.scm (defmacro:expand*): replaces "defmacro.scm". Other + defmacro functions now supported in all implementations. + +Sun Feb 13 12:38:39 1994 Aubrey Jaffer (jaffer@jacal) + + * defmacro.scm (defmacro:macroexpand*): now expands quasiquotes + correctly. + +Sat Feb 12 21:23:56 1994 Aubrey Jaffer (jaffer@jacal) + + * hashtab.scm ((predicate->hash pred)): moved from hash.scm. + +Tue Feb 8 01:07:00 1994 Aubrey Jaffer (jaffer@jacal) + + * Template.scm *.init (slib:load-source slib:load-compiled + slib:load): support for loading compiled modules added. + Dependence on SCHEME-FILE-SUFFIX removed. + + * require.scm (require:require): Added support for 'source and + 'compiled features. + +Sat Feb 5 00:19:38 1994 Aubrey Jaffer (jaffer@jacal) + + * stdio.scm ((stdio:sprintf)): Now truncates printing if you run + out of string. + +Fri Feb 4 00:54:14 1994 Aubrey Jaffer (jaffer@jacal) + + From: pk@kaulushaikara.cs.tut.fi (Kellom'ki Pertti) + * (psd/primitives.scm): Here is a patch removing some problems + with psd-1.1, especially when used with Scheme 48. Thanks to + Jonathan Rees for poiting them out. The patch fixes two problems: + references to an unused variable *psd-previous-line*, and the + correct number of arguments to write-char. + +Fri Jan 14 00:37:19 1994 Aubrey Jaffer (jaffer@jacal) + + * require.scm (require:require): Now supports (feature . + argument-list) associations. + +Sat Nov 13 22:07:54 1993 (jaffer at jacal) + + * slib.info (Structures): added. Bug - struct.scm and + structure.scm do not implement the same macros. + +Mon Nov 1 22:17:01 1993 (jaffer at jacal) + + * array.scm (array-dimensions array-rank array-in-bounds?): + added. + +Sat Oct 9 11:54:54 1993 (jaffer at jacal) + + * require.scm (*catalog* portable-scheme-debugger): support added + for psd subdirectory. + +Tue Sep 21 11:48:26 1993 Aubrey Jaffer (jaffer at wbtree) + + * Makefile (lineio.scm rbtree.scm rbtest.scm scmacro.scm + sc4sc3.scm scaespp.scm scaglob.scm scainit.scm scamacr.scm + scaoutp.scm strcase.scm): hyphens removed from names. + +Mon Sep 20 00:57:29 1993 (jaffer at jacal) + + * arraymap.scm (array-map! array-for-each array-indexes): added. + +Sun Sep 19 19:20:49 1993 (jaffer at jacal) + + * require.scm (require:feature->path require:require *catalog*): + associations of the form (symbol1 . symbol2) in *catalog* look up + symbol2 whenever symbol1 is specified. + +Mon Sep 13 22:12:00 1993 (jaffer at jacal) + + From: sperber@provence.informatik.uni-tuebingen.de (Michael Sperber) + * elk.init: updated to ELK version 2.1. + +Sat Sep 11 21:17:45 1993 (jaffer at jacal) + + * hashtab.scm (hash-for-each): fixed and documented (also + documented alist.scm). + +Fri Sep 10 15:57:50 1993 (jaffer at jacal) + + * getopt.scm (getopt *optind* *optarg*): added. + +Tue Sep 7 23:57:40 1993 (jaffer at jacal) + + * slib1d3 released. + * comlist.scm: prefixed all functions with "comlist:". + +Tue Aug 31 23:59:28 1993 (jaffer at jacal) + + * Template.scm *.init (output-port-height): added. + +Wed May 26 00:00:51 1993 Aubrey Jaffer (jaffer at camelot) + + * hashtab.scm (hash-map hash-for-each): added. + * alist.scm (alist-map alist-for-each): added. + +Tue May 25 22:49:01 1993 Aubrey Jaffer (jaffer at camelot) + + * comlist.scm (delete delete-if atom): renamed as in common lisp. + * comlist.scm (delete-if-not): added. + * tree.scm: moved tree functions out of comlist.scm + +Mon May 24 10:28:22 1993 Aubrey Jaffer (jaffer at camelot) + + From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) + * modular.scm: improvements and fixed bug in modular:expt. + +Fri May 14 01:26:44 1993 Aubrey Jaffer (jaffer at camelot) + + * slib1d2 released. + + From: Dave Love <d.love@daresbury.ac.uk> + * comlist.scm: added some tree functions. + * yasos.scm collect.scm: fixed name conflicts and documentation. + +Tue May 11 01:22:40 1993 Aubrey Jaffer (jaffer at camelot) + + * eval.scm: removed because all *.init files support it. + + * hash.scm: made all hash functions case-insensitive. Equal + inexact and exact numbers now hash to the same code. + + From: eigenstr@falstaff.cs.rose-hulman.edu: + * slib.texi: revised. + +Sun May 9 01:43:11 1993 Aubrey Jaffer (jaffer at camelot) + + From: kend@newton.apple.com (Ken Dickey) + * macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm: Macros no + longer expand builtin Scheme forms. + + From: William Clinger <will@skinner.cs.uoregon.edu> + * macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm: Macros that + work added. + +Sat May 1 23:55:42 1993 Aubrey Jaffer (jaffer at montreux) + + * random.scm (random:random): sped up for exact arguments. + +Wed Apr 28 00:24:36 1993 Aubrey Jaffer (jaffer at camelot) + + From: lutzeb@flp.cs.tu-berlin.de (Dirk Lutzebaeck) + * format.scm formatfl.scm formatst.scm slib.texi: Format 2.3. + * implemented floating point support ~F,~E,~G,~$ + * automatic detection if the scheme interpreter support flonums. + * the representation of internal objects can be selected to be + #<...> or #[...] or other forms + * new/redefintion of configuration variables format:abort, + format:floats, format:formatfl-path, format:iobj-pref, format:iobj-post + * added string-index + * added MIT Scheme 7.1 custom types + * for efficiencies reasons the error continuation is only used if + format:abort is not available + * improved error presentation and error handling + * tested with scm4b/c, Elk 2.0, MIT Scheme 7.1, Scheme->C 01Nov91, + UMB Scheme 2.5/2.10 + +Sun Apr 25 22:40:45 1993 Aubrey Jaffer (jaffer at camelot) + + From: Dave Love <d.love@daresbury.ac.uk> + * scheme2c.init: corrections and portability improvements. + * yasos.scm collect.scm: +These correct the scheme2c.init and a couple of other things as well as +hiding some non-exported definitions and removing an example from +collect.scm to the manual. + +Sat Apr 3 00:48:13 1993 Aubrey Jaffer (jaffer at camelot) + + From: eigenstr@cs.rose-hulman.edu (Todd R. Eigenschink) + * slib.texi: created. + +Thu Mar 25 01:47:38 1993 Aubrey Jaffer (jaffer at camelot) + + From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) + * sca-init.scm sca-glob.scm sca-macr.scm sca-outp.scm + sca-expp.scm: syntax-case macros added. + +Wed Mar 24 23:12:49 1993 Aubrey Jaffer (jaffer at camelot) + + * comlist.scm (some every notany notevery): Now accept multiple + arguments. NOTANY added. + +Wed Mar 3 01:19:11 1993 Aubrey Jaffer (jaffer at camelot) + + From: "Dan Friedman" <dfried@cs.indiana.edu> + * struct.scm structst.scm: added. + +Tue Mar 2 00:28:00 1993 Aubrey Jaffer (jaffer at camelot) + + * obj2str (object->string): now handles symbols and number without + going to string-port. + +Sun Feb 28 22:22:50 1993 Aubrey Jaffer (jaffer at camelot) + + * all files with Jaffer copyright: Now have explicit conditions + for use and copying. + +Fri Feb 26 00:29:18 1993 Aubrey Jaffer (jaffer at camelot) + + * obj2str: redefined in terms of string ports. + + * pp2str: eliminated. + +Mon Feb 22 17:21:21 1993 Aubrey Jaffer (jaffer at camelot) + + From: dorai@cs.rice.edu (Dorai Sitaram) + * strport.scm: string ports. + + From: Alan@LCS.MIT.EDU (Alan Bawden) + * array.scm: functions which implement arrays. + +Wed Feb 17 00:18:57 1993 Aubrey Jaffer (jaffer at camelot) + + * repl.scm: split off from sc-macro.scm. + + * eval.scm *.init Template.scm (eval!): eliminated. + + From: dorai@cs.rice.edu (Dorai Sitaram) + * defmacro.scm: added. Chez, elk, mitscheme, scheme2c, and scm + support. + +Tue Feb 16 00:23:07 1993 Aubrey Jaffer (jaffer at camelot) + + * require.doc (output-port-width current-error-port tmpnam + file-exists? delete-file force-output char-code-limit + most-positive-fixnum slib:tab slib:form-feed error):descriptions + added. + + * *.init (tmpnam): now supported by all. + + From: dorai@cs.rice.edu (Dorai Sitaram) + * chez.init elk.init mitscheme.init scheme2c.init (defmacro macro? + macro-expand): added. + +Mon Feb 15 00:51:22 1993 Aubrey Jaffer (jaffer at camelot) + + * Template.scm *.init (file-exists? delete-file): now defined for + all implementations. + +Sat Feb 13 23:40:22 1993 Aubrey Jaffer (jaffer at camelot) + + * chez.init (slib:error): output now directed to + (current-error-port). + +Thu Feb 11 01:23:25 1993 Aubrey Jaffer (jaffer at camelot) + + * withfile.scm (with-input-from-file with-output-from-file): now + close file on thunk return. + + * *.init (current-error-port): added. + +Wed Feb 10 17:57:15 1993 Aubrey Jaffer (jaffer at camelot) + + * mitscheme.init (values dynamic-wind): added to *features*. + + From: mafm@cs.uwa.edu.au (Matthew MCDONALD) + * mitcomp.pat: added patch file of definitions for compiling SLIB + with MitScheme. + +Tue Feb 9 10:49:12 1993 Aubrey Jaffer (jaffer at camelot) + + From: jt@linus.mitre.org (F. Javier Thayer) + * t3.init: additions and corrections. + +Mon Feb 8 20:27:18 1993 Aubrey Jaffer (jaffer at camelot) + + From: dorai@cs.rice.edu (Dorai Sitaram) + * chez.init: added. + +Wed Feb 3 23:33:49 1993 Aubrey Jaffer (jaffer at camelot) + + * sc-macro.scm (macro:repl): now prints error message for errors. + +Mon Feb 1 22:22:17 1993 Aubrey Jaffer (jaffer at camelot) + + * logical.scm (logor): changed to logior to be compatible with + common Lisp. + +Fri Jan 29 17:15:03 1993 Aubrey Jaffer (jaffer at camelot) + + From: jt@linus.mitre.org (F. Javier Thayer) + * t3.init: modified so it passes most of SCM/test.scm. + +Sun Jan 24 00:18:13 1993 Aubrey Jaffer (jaffer at camelot) + + * comlist.scm (intersection): added. + +Wed Jan 13 19:01:11 1993 Aubrey Jaffer (jaffer at camelot) + + * debug.scm: (debug:qp): needed to shadow quotient. + +Sat Jan 9 13:44:44 1993 Aubrey Jaffer (jaffer at camelot) + + * rb-tree.scm: changed use of '() and NULL? to #f and NOT. + + * rb-tree.scm (rb-insert! rb-delete!) added ! to names. + +Fri Jan 8 01:17:16 1993 Aubrey Jaffer (jaffer at camelot) + + * rb-tree.doc: added. + + From: pgs@ai.mit.edu (Patrick Sobalvarro) + * rb-tree.scm rbt-test.scm: code for red-black trees added. + +Tue Jan 5 14:57:02 1993 Aubrey Jaffer (jaffer at camelot) + + From: lutzeb@cs.tu-berlin.de (Dirk Lutzebaeck) + * format.scm formatst.scm format.doc: version 2.2 + * corrected truncation for fixed fields by negative field parameters + inserted a '<' or a '>' when field length was equal to object string + length + * changed #[...] outputs to #<...> outputs to be conform to SCM's + display and write functions + * changed #[non-printable-object] output to #<unspecified> + * ~:s and ~:a print #<...> messages in strings "#<...>" so that the + output can always be processed by (read) + * changed implementation dependent part: to configure for various scheme + systems define the variable format:scheme-system + * format:version is a variable returning the format version in a string + * format:custom-types allows to use scheme system dependent predicates + to identify the type of a scheme object and its proper textual + representation + * tested with scm4a14, Elk 2.0 + +Tue Dec 22 17:36:23 1992 Aubrey Jaffer (jaffer at camelot) + + * Template.scm *.init (char-code-limit): added. + + * debug.scm (qp): qp-string had bug when printing short strings + when room was less than 3. + + * random.scm (random:size-int): now takes most-positive-fixnum + into account. + +Wed Nov 18 22:59:34 1992 Aubrey Jaffer (jaffer at camelot) + + From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) + * randinex.scm (random:normal-vector! random:normal + random:solid-sphere random:hollow-sphere): new versions fix bug. + +Tue Nov 17 14:00:15 1992 Aubrey Jaffer (jaffer at Ivan) + + * str-case.scm (string-upcase string-downcase string-capitalize + string-upcase! string-downcase! string-capitalize!): moved from + format.scm. + +Fri Nov 6 01:09:38 1992 Aubrey Jaffer (jaffer at Ivan) + + * require.scm (require): uses base:load instead of load. + + * sc-macro.scm (macro:repl): now uses dynamic-wind. + +Mon Oct 26 13:21:04 1992 Aubrey Jaffer (jaffer at Ivan) + + * comlist.scm (nthcdr last) added. + +Sun Oct 25 01:50:07 1992 Aubrey Jaffer (jaffer at Ivan) + + * line-io.scm: created + +Mon Oct 19 12:53:01 1992 Aubrey Jaffer (jaffer at camelot) + + From: dorai@cs.rice.edu + * fluidlet.scm: FLUID-LET that works. + +Thu Oct 8 22:17:01 1992 Aubrey Jaffer (jaffer at camelot) + + From: Robert Goldman <rpg@rex.cs.tulane.edu> + * mitscheme.init: improvements. + +Sun Oct 4 11:37:57 1992 Aubrey Jaffer (jaffer at camelot) + + * values.scm values.doc: Documentation rewritten and combined + into values.scm + +Thu Oct 1 23:29:43 1992 Aubrey Jaffer (jaffer at Ivan) + + * sc-macro.scm sc-macro.doc: documentation improved and moved into + sc-macro.doc. + +Mon Sep 21 12:07:13 1992 Aubrey Jaffer (jaffer at Ivan) + + * sc-macro.scm (macro:load): now sets and restores *load-pathname*. + + * eval.scm (slib:eval!): (program-vicinity) now correct during + evaluation. + + * Template.scm, *.init: i/o-redirection changed to with-file. + *features* documentation changed. + + From: Stephen J Bevan <bevan@computer-science.manchester.ac.uk> + * t3.init: new. Fixes problems with require, substring, and + <,>,<=,>= with more than 2 arguments. + +Fri Sep 18 00:10:57 1992 Aubrey Jaffer (jaffer at Ivan) + + From andrew@astro.psu.edu Wed Sep 16 17:58:21 1992 + * dynamic.scm: added. + + From raible@nas.nasa.gov Thu Sep 17 22:28:25 1992 + * fluidlet.scm: added. + +Sun Sep 13 23:08:46 1992 Aubrey Jaffer (jaffer at Ivan) + + * sc-macro.scm (macro:repl): moved (require 'debug) into syntax-error. + + * dynwind.scm, withfile.scm, trnscrpt.scm: created. + + From kend@data.rain.com Sun Sep 13 21:26:59 1992 + * collect.scm: created. + * oop.scm => yasos.scm: updated. + * oop.doc: removed. + + From: Stephen J. Bevan <bevan@cs.man.ac.uk> 19920912 + * elk.init: created + +Tue Jul 14 11:42:57 1992 Aubrey Jaffer (jaffer at Ivan) + + * tek41.scm tek40.scm: added. + +Tue Jul 7 00:55:58 1992 Aubrey Jaffer (jaffer at Ivan) + + * record.scm record.doc (record-sub-predicate): added. + + * sc-macro.scm (macro:repl): syntax-errors now return into + macro:repl. + + * debug.scm (qp): removed (newline). Added qpn (qp with newline). + +Sun Jun 14 22:57:32 1992 Aubrey Jaffer (jaffer at Ivan) + + * slib1b8 released. + +Sat Jun 13 17:01:41 1992 Aubrey Jaffer (jaffer at Ivan) + + * alist.scm ppfile.scm: added. + + * hash.scm hashtab.scm scheme48.init: added. + + * sc-macro.scm (macro:repl): created. macro:load now uses + eval:eval!. + + * eval.scm (eval:eval!) created and eval done in terms of it. + + * prime.scm (prime:prime?) fixed misplaced parenthesis. + +Wed May 27 16:13:17 1992 Aubrey Jaffer (jaffer at Ivan) + + From: "Chris Hanson" <cph@martigny.ai.mit.edu> + * synrul.scm (generate-match): fixed for CASE syntax. + +Wed May 20 00:25:40 1992 Aubrey Jaffer (jaffer at Ivan) + + * slib1b6 released. + + * Template.scm gambit.init mitscheme.init scheme2c.init: + rearranged *features*. + +Tue May 19 22:51:28 1992 Aubrey Jaffer (jaffer at Ivan) + + * scmactst.scm: test cases fixed. + + From: "Chris Hanson" <cph@martigny.ai.mit.edu> + * r4syn.scm (make-r4rs-primitive-macrology): TRANSFORMER added + back in. + + * require.scm (load): load now passes through additional + arguments to *old-load*. + +Mon May 18 00:59:36 1992 Aubrey Jaffer (jaffer at Ivan) + + * mulapply.scm (apply): written. + + * record.scm record.doc (make-record-sub-type): added. + +Fri May 8 17:55:14 1992 Aubrey Jaffer (jaffer at Ivan) + + * process.scm: created, but not finished. + + From: hugh@ear.mit.edu (Hugh Secker-Walker) + * comlist.scm (nreverse make-list): non-recursive versions added. + + * sc2.scm (1+ -1+): versions which capture +. + + * mularg.scm (- /): created. + +Wed Apr 8 00:05:30 1992 Aubrey Jaffer (jaffer at Ivan) + + * require.scm sc-macro.scm (catalog): Now uses macro:load if + 'macro is part of catalog entry. + + From: Andrew Wilcox (awilcox@astro.psu.edu) + * queue.scm: created. + +Sun Mar 15 12:23:06 1992 Aubrey Jaffer (jaffer at Ivan) + + * comlist.scm (notevery): fixed. Now (not (every ..)). + + * eval.scm (eval:eval): renamed to slib:eval. + + * record.scm: replaced with version from From: david carlton + <carlton@husc.harvard.edu>. I changed updater => modifier, put + record-predicate into the rtd, and bummed code mercilessly. + + From: plogan@std.mentor.com (Patrick Logan) + * sc3.scm (last-pair): changed from testing null? to pair?. diff --git a/module/slib/DrScheme.init b/module/slib/DrScheme.init new file mode 100644 index 000000000..067625091 --- /dev/null +++ b/module/slib/DrScheme.init @@ -0,0 +1,6 @@ +;;;"DrScheme.init" Initialization for SLIB for DrScheme -*-scheme-*- +;; Friedrich Dominicus <frido@q-software-solutions.com> +;; Newsgroups: comp.lang.scheme +;; Date: 02 Oct 2000 09:24:57 +0200 + +(require-library "init.ss" "slibinit") diff --git a/module/slib/FAQ b/module/slib/FAQ new file mode 100644 index 000000000..8b8a63648 --- /dev/null +++ b/module/slib/FAQ @@ -0,0 +1,217 @@ +FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib2d1). +Written by Aubrey Jaffer (http://swissnet.ai.mit.edu/~jaffer). + + 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 supported by Bigloo, Chez, DrScheme, ELK, GAMBIT, MacScheme, +MITScheme, PocketScheme, RScheme Scheme->C, Scheme48, SCM, SCSH, T3.1, +UMB-Scheme, and VSCM. + +[] How can I obtain SLIB? + +SLIB is available via http from: + http://swissnet.ai.mit.edu/~jaffer/SLIB.html +SLIB is available via ftp from: + swissnet.ai.mit.edu:/pub/scm/ + +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: + ftp.gnu.org:/pub/gnu/texinfo/texinfo-3.12.tar.gz + +[] How often is SLIB released? + +Several times a year. + +[] What is the latest version? + +The version as of this writing is slib2d1. The latest documentation +is available online at: + http://swissnet.ai.mit.edu/~jaffer/SLIB.html + +[] Which 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? If you set SCHEME_LIBRARY_PATH, make +sure that the Scheme 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, that line is (require 'random). + +[] Why doesn't SLIB just load all the functions so I don't have + to type require statements? + +SLIB 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 Scheme implementations predate the adoption of the R4RS macro +specification. All of the implementations except scheme48 version +0.45 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 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 would also be true for a Scheme implementation which didn't +support DEFMACRO. The lines in this case would be: + (require 'repl) + (repl:top-level defmacro:eval) + +[] I always use R4RS macros with an implementation which doesn't + natively support them. How can I avoid having to type require + statements every time I start Scheme? + +As explained in the Repl entry in slib.info (or slib.texi): + + To have your top level loop always use macros, add any interrupt + catching code and the following script to your Scheme init file: + (require 'macro) + (require 'repl) + (repl:top-level macro:eval) diff --git a/module/slib/Makefile b/module/slib/Makefile new file mode 100644 index 000000000..023e0ef55 --- /dev/null +++ b/module/slib/Makefile @@ -0,0 +1,333 @@ +# Makefile for Scheme Library +# Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 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/ +PREVDOCS = slib/ +dvidir=../dvi/ +dvi: $(dvidir)slib.dvi +$(dvidir)slib.dvi: version.txi slib.texi $(dvidir)slib.fn schmooz.texi +# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)slib.texi + -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex slib.??) + cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi +$(dvidir)slib.fn: + cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi \ + $(srcdir)schmooz.texi +xdvi: $(dvidir)slib.dvi + xdvi -s 6 $(dvidir)slib.dvi +htmldir=../public_html/ +slib_toc.html: version.txi slib.texi htmlform.txi schmooz.texi + texi2html -split -verbose slib.texi + +$(PREVDOCS)slib_toc.html: + cd slib;make slib_toc.html + cd slib;texi2html -split -verbose slib.texi + +html: $(htmldir)slib_toc.html +$(htmldir)slib_toc.html: slib slib_toc.html Makefile + hitch $(PREVDOCS)slib_\*.html slib_\*.html $(htmldir) + +rpm_prefix=/usr/src/redhat/ + +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 +INSTALL_DATA = install -c + +slib48.036: + (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 + +$(LIB)/slibcat: + touch $(LIB)/slibcat + +slib48: $(LIB)/slibcat Makefile + (echo ",batch on"; \ + echo ",config"; \ + echo ",load =scheme48/misc/packages.scm"; \ + echo "(define-structure slib-primitives"; \ + echo " (export s48-error"; \ + echo " s48-ascii->char"; \ + echo " s48-force-output"; \ + echo " s48-current-error-port"; \ + echo " s48-system";\ + echo " s48-with-handler";\ + echo " s48-getenv)";\ + echo " (open scheme signals ascii extended-ports i/o"; \ + echo " primitives handle unix-getenv)"; \ + echo " (begin"; \ + echo " (define s48-error error)"; \ + echo " (define s48-ascii->char ascii->char)"; \ + echo " (define s48-force-output force-output)"; \ + echo " (define s48-current-error-port current-error-port)"; \ + echo " (define (s48-system c) (vm-extension 96 c))"; \ + echo " (define s48-with-handler with-handler)"; \ + echo " (define s48-getenv getenv)))"; \ + echo ",user"; \ + echo ",open slib-primitives"; \ + echo "(define (implementation-vicinity) \"$(LIB)/\")"; \ + echo "(define (library-vicinity) \"`pwd`/\")"; \ + echo ",load scheme48.init"; \ + echo "(define *args* '())"; \ + echo "(define (program-arguments) (cons \"scheme48\" *args*))"; \ + echo "(set! *catalog* #f)"; \ + echo ",collect"; \ + echo ",batch off"; \ + echo ",dump $(IMAGE) \"(slib $(VERSION))\""; \ + echo ",exit") | scheme48 + +install48: slib48 + $(INSTALL_DATA) $(IMAGE) $(LIB) + (echo '#!/bin/sh'; \ + echo exec $(RUNNABLE) -i '$(LIB)/$(IMAGE)' \"\$$\@\") \ + > $(bindir)/slib48 + chmod +x $(bindir)/slib48 + +#### Stuff for maintaining SLIB below #### + +VERSION = 2d1 +ver = $(VERSION) +version.txi: Makefile + echo @set SLIBVERSION $(VERSION) > version.txi + echo @set SLIBDATE `date +"%B %Y"` >> version.txi + +scheme = scm + +htmlform.txi: *.scm + $(scheme) -rschmooz -e'(schmooz "slib.texi")' +slib.info: version.txi slib.texi htmlform.txi objdoc.txi schmooz.texi + makeinfo slib.texi --no-split -o slib.info + mv slib.info slib$(VERSION).info + if [ -f $(PREVDOCS)slib.info ]; \ + then infobar $(PREVDOCS)slib.info slib$(VERSION).info slib.info; \ + else cp slib$(VERSION).info slib.info;fi +info: installinfo +installinfo: $(infodir)/slib.info +$(infodir)/slib.info: slib.info + cp -a slib.info $(infodir)/slib.info + -install-info $(infodir)/slib.info $(infodir)/dir + -rm $(infodir)/slib.info.gz +infoz: installinfoz +installinfoz: $(infodir)/slib.info.gz +$(infodir)/slib.info.gz: $(infodir)/slib.info + gzip -f $(infodir)/slib.info + +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 prec.scm schmooz.scm +lfiles = sort.scm comlist.scm tree.scm logical.scm random.scm tsort.scm \ + coerce.scm +revfiles = sc4opt.scm sc4sc3.scm sc2.scm mularg.scm mulapply.scm \ + trnscrpt.scm withfile.scm dynwind.scm promise.scm values.scm \ + eval.scm +afiles = ratize.scm randinex.scm modular.scm factor.scm \ + charplot.scm root.scm minimize.scm cring.scm determ.scm \ + selfset.scm psxtime.scm cltime.scm timezone.scm tzfile.scm +bfiles = collect.scm fluidlet.scm struct.scm object.scm recobj.scm yasyn.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 byte.scm nclients.scm pnm.scm \ + simetrix.scm +rfiles = rdms.scm alistab.scm dbutil.scm paramlst.scm report.scm \ + batch.scm makcrc.scm dbrowse.scm comparse.scm getopt.scm \ + htmlform.scm db2html.scm http-cgi.scm getparam.scm glob.scm \ + fft.scm uri.scm +gfiles = tek40.scm tek41.scm +docfiles = ANNOUNCE README FAQ slib.info slib.texi schmooz.texi ChangeLog \ + coerce.txi lineio.txi nclients.txi factor.txi minimize.txi \ + obj2str.txi randinex.txi random.txi uri.txi db2html.txi \ + htmlform.txi http-cgi.txi version.txi fmtdoc.txi objdoc.txi +mfiles = Makefile require.scm Template.scm syncase.sh mklibcat.scm \ + Bev2slib.scm slib.spec +ifiles = bigloo.init chez.init elk.init macscheme.init \ + mitscheme.init scheme2c.init scheme48.init gambit.init t3.init \ + vscm.init mitcomp.pat scm.init scsh.init pscheme.init STk.init \ + RScheme.init DrScheme.init umbscheme.init +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 +RSYNC=rsync -avessh +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 +#For change-barred HTML. +slib: + unzip -a $(dest)slib[0-9]*.zip + +distinfo: $(dest)slib.info.zip +$(dest)slib.info.zip: infotemp/slib + $(makedev) TEMP=infotemp/ DEST=$(dest) PROD=slib ver=.info zip + rm -rf infotemp + +release: dist rpm + cvs tag -F slib$(VERSION) + cp ANNOUNCE $(htmldir)SLIB_ANNOUNCE.txt + $(RSYNC) $(htmldir)SLIB.html $(htmldir)SLIB_ANNOUNCE.txt nestle.ai.mit.edu:public_html/ + $(RSYNC) $(dest)README $(dest)slib$(VERSION).zip \ + $(dest)slib-$(VERSION)-1.noarch.rpm nestle.ai.mit.edu:dist/ +# upload $(dest)README $(dest)slib$(VERSION).zip ftp.gnu.org:gnu/jacal/ +# $(MAKE) indiana +indiana: + upload $(dest)slib$(VERSION).zip ftp@ftp.cs.indiana.edu:/pub/scheme-repository/incoming + echo -e \ + 'I have uploaded slib$(VERSION).zip to ftp.cs.indiana.edu:/pub/scheme-repository/incoming\n' \ + 'for placement into ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/' \ + | mail -s 'SLIB upload' -b jaffer scheme-repository-request@cs.indiana.edu + +postnews: + echo -e "Newsgroups: comp.lang.scheme\n" | cat - ANNOUNCE | \ + inews -h -O -S \ + -f "announce@docupress.com (Aubrey Jaffer & Radey Shouman)" \ + -t "SLIB$(VERSION) Released" -d world + +upzip: $(HOME)/pub/slib.zip + $(RSYNC) $(HOME)/pub/slib.zip nestle.ai.mit.edu:pub/ + +dist: $(dest)slib$(VERSION).zip +$(dest)slib$(VERSION).zip: temp/slib + $(makedev) DEST=$(dest) PROD=slib ver=$(VERSION) zip + +rpm: $(dest)slib-$(VERSION)-1.noarch.rpm +$(dest)slib-$(VERSION)-1.noarch.rpm: $(dest)slib$(VERSION).zip + cp $(dest)slib$(VERSION).zip $(rpm_prefix)SOURCES + rpm -bb --clean slib.spec + rm $(rpm_prefix)SOURCES/slib$(VERSION).zip + mv $(rpm_prefix)RPMS/noarch/slib-$(VERSION)-1.noarch.rpm $(dest) + +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 +doszip: /c/scm/dist/slib$(VERSION).zip +/c/scm/dist/slib$(VERSION).zip: temp/slib + $(makedev) DEST=/c/scm/dist/ PROD=slib ver=$(VERSION) zip + zip -d /c/scm/dist/slib$(VERSION).zip slib/slib.info +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=$(VERSION) 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/ + +new: + echo `date` \ Aubrey Jaffer \ \<`whoami`@`hostname`\>> change + echo>> change + echo \ \* require.scm \(*SLIB-VERSION*\): Bumped from $(VERSION) to $(ver).>>change + echo>> change + cat ChangeLog >> change + mv -f change ChangeLog + $(CHPAT) slib$(VERSION) slib$(ver) ANNOUNCE FAQ ../scm/ANNOUNCE \ + ../jacal/ANNOUNCE ../wb/README ../wb/ANNOUNCE \ + ../synch/ANNOUNCE \ + $(htmldir)README.html ../dist/README \ + $(htmldir)JACAL.html \ + $(htmldir)SCM.html $(htmldir)Hobbit.html \ + $(htmldir)SIMSYNCH.html ../scm/scm.texi \ + /c/scm/dist/install.bat /c/scm/dist/makefile \ + /c/scm/dist/mkdisk.bat + $(CHPAT) slib-$(VERSION) slib-$(ver) ANNOUNCE FAQ ../scm/ANNOUNCE \ + ../jacal/ANNOUNCE ../wb/README ../wb/ANNOUNCE \ + ../synch/ANNOUNCE \ + $(htmldir)README.html ../dist/README \ + $(htmldir)JACAL.html \ + $(htmldir)SCM.html $(htmldir)Hobbit.html \ + $(htmldir)SIMSYNCH.html ../scm/scm.texi \ + /c/scm/dist/install.bat /c/scm/dist/makefile \ + /c/scm/dist/mkdisk.bat + $(CHPAT) $(VERSION) $(ver) README slib.texi require.scm Makefile \ + $(htmldir)SLIB.html slib.spec + cvs commit -m '(*SLIB-VERSION*): Bumped from $(VERSION) to $(ver).' + cvs tag -F slib$(ver) + +tagfiles = version.txi slib.texi $(mfiles) $(sfiles) $(bfiles) $(tfiles) \ + $(ifiles) +# 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) +report: + scmlit -e"(slib:report #t)" + scm -e"(slib:report #t)" +clean: + -rm -f *~ *.bak *.orig *.rej core a.out *.o \#* + -rm -rf *temp +distclean: realclean +realclean: + -rm -f *~ *.bak *.orig *.rej TAGS core a.out *.o \#* + -rm -f slib.info* slib.?? slib.??? + -rm -rf *temp +realempty: temp/slib + -rm -f $(allfiles) diff --git a/module/slib/README b/module/slib/README new file mode 100644 index 000000000..4b55b610c --- /dev/null +++ b/module/slib/README @@ -0,0 +1,297 @@ +This directory contains the distribution of Scheme Library slib2d1. +Slib conforms to Revised^5 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. + http://swissnet.ai.mit.edu/~jaffer/SLIB.html + + MANIFEST + + `README' is this file. It contains a MANIFEST, INSTALLATION + INSTRUCTIONS, and coding guidelines. + `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. + `bigloo.init' is a configuration file for Bigloo. + `chez.init' is a configuration file for Chez Scheme. + `DrScheme.init' is a configuration file for DrScheme. + `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. + `pscheme.init' is configuration file for PocketScheme 0.2.5 (WinCE SIOD) + `RScheme.init' is a configuration file for RScheme. + `scheme2c.init' is a configuration file for DEC's scheme->c. + `scheme48.init' is a configuration file for Scheme48. + `scsh.init' is a configuration file for Scheme-Shell + `scm.init' is a configuration file for SCM. + `t3.init' is a configuration file for T3.1 in Scheme mode. + `STk.init' is a configuration file for STk. + `umbscheme.init' is a configuration file for umb-scheme. + `vscm.init' is a configuration file for VSCM. + `mklibcat.scm' builds the *catalog* cache. + `require.scm' has code which allows system independent access to + the library files. + + `Bev2slib.scm' Converts Stephen Bevan's "*.map" files to SLIB catalog entries. + `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. + `minimize.scm' has Golden Section Search for minimum value. + `cring.scm' extend + and * to custom commutative rings. + `selfset.scm' sets single letter identifiers to their symbols. + `determ.scm' compute determinant of list of lists. + `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. + `psxtime.scm' has Posix time conversion routines. + `cltime.scm' has Common-Lisp time conversion routines. + `timezone.scm' has the default time-zone, UTC. + `tzfile.scm' reads sysV style (binary) timezone file. + `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. + `htmlform.scm' generates HTML-3.2 with forms. + `db2html.scm' convert relational database to hyperlinked tables and + pages. + `http-cgi.scm' serves WWW pages with HTTP or CGI. + `uri.scm' encodes and decodes Uniform Resource Identifiers. + `dbrowse.scm' browses relational databases. + `paramlst.scm' has procedures for passing parameters by name. + `getparam.scm' has procedures for converting getopt to parameters. + `report.scm' prints database reports. + `schmooz.scm' is a simple, lightweight markup language for + interspersing Texinfo documentation with Scheme source code. + `glob.scm' has filename matching and manipulation. + `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 an object system. + `yasyn.scm' defines (syntax-rules) macros for object oriented programming. + `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. + `coerce.scm' has coerce and type-of from Common-Lisp. + `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 dynamic-wind from R5RS. + `eval.scm' has eval with environments from R5RS. + `dwindtst.scm' has routines for characterizing dynamic-wind. + `dynamic.scm' has DYNAMIC data type [obsolete]. + `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. + `byte.scm' has arrays of small integers. + `nclients.scm' provides a Scheme interface to FTP and WWW Browsers. + `pnm.scm' provides a Scheme interface to "portable bitmap" files. + `simetrix.scm' provides SI Metric Interchange Format. + + 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'. Scheme48 +supports `getenv' but does not use it for determining +`library-vicinity'. (That is done from the Makefile.) + + 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. + + - Implementation: SCM + The SCM implementation does not require any initialization file as + SLIB support is already built into SCM. See the documentation + with SCM for installation instructions. + + - Implementation: VSCM + 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. + + 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")' + + 4. 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.) + + + - Implementation: Scheme48 + To make a Scheme48 image for an installation under `<prefix>', + + 1. `cd' to the SLIB directory + + 2. type `make prefix=<prefix> slib48'. + + 3. To install the image, type `make prefix=<prefix> install48'. + This will also create a shell script with the name `slib48' + which will invoke the saved image. + + - Implementation: PLT Scheme + - Implementation: DrScheme + - Implementation: MzScheme + Date: Mon, 2 Oct 2000 21:29:48 -0400 (EDT) + From: Shriram Krishnamurthi <sk@cs.brown.edu> + + We distribute an SLIB init file for our system. If you have PLT + Scheme (our preferred name for the entire suite, which includes + DrScheme, MzScheme and other implementations) installed, you ought + to be able to run "help-desk", or run `drscheme' and choose Help + Desk from the Help menu; in Help Desk, type `slib'. This will give + instructions for how to load the SLIB init file. + + 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', + `Revised(4) Report on the Algorithmic Language Scheme', or + `Revised(5) Report on the Algorithmic Language Scheme' +in order 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 GUIDELINES + + 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/module/slib/RScheme.init b/module/slib/RScheme.init new file mode 100644 index 000000000..15b89b300 --- /dev/null +++ b/module/slib/RScheme.init @@ -0,0 +1,290 @@ +;;;"RScheme.init" Initialization for SLIB for RScheme -*-scheme-*- +;;;; From http://www.rscheme.org/rs/pg1/RScheme.scm +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. +;;; +;;; adapted for RScheme by Donovan Kolbly -- (v1 1997-09-14) +;;; +;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) 'RScheme) + +;;; (scheme-implementation-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) "http://www.rscheme.org/") + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "0.7.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/rs/0.7.1/") + ((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/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) (os-file-exists? 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) + (flush-output-port (if (null? arg) + (current-output-port) + (car arg)))) + +;;; 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 65536) + +;;; 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 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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;;; define an error procedure for the library +(define (slib:error msg . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (error "~a ~j" msg args)) + +;;; 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 (process-exit 0))) + +;;; 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/module/slib/STk.init b/module/slib/STk.init new file mode 100644 index 000000000..26ab01c61 --- /dev/null +++ b/module/slib/STk.init @@ -0,0 +1,256 @@ +;;;"STk.init" SLIB Initialization for STk -*-scheme-*- +;;; Authors: Erick Gallesio (eg@unice.fr) and Aubrey Jaffer. +;;; +;;; This code is in the public domain. + +(require "unix") + +;;; (software-type) should be set to the generic operating system type. +;;; UNIX, VMS, MACOS, AMIGA and MSDOS are supported. + +(define (software-type) 'UNIX) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. + +(define (scheme-implementation-type) '|STk|) + +;;; (scheme-implementation-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) + "http://kaolin.unice.fr/STk/STk.html") + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) (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) "/usr/local/lib/stk/3.99.3/") + +;;; (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") "/usr/local/lib/slib/"))) + (lambda () library-path))) + +;;; +;;; +(define home-vicinity + (let ((home-path (or (getenv "HOME") "/"))) + (lambda () home-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 ; commented because icomplete +; queue ;queues +; pretty-print +; object->string +; format +; 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) + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (string-append "slib_" (number->string cntr))))) + +;;; (DELETE-FILE <string>) +(define (delete-file f) (system (format #f "/bin/rm ~A" 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) (apply flush arg)) + +;;; 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) + +;;; 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 *macros* '()) + +(define-macro (defmacro name args . body) + `(begin + (define-macro (,name ,@args) ,@body) + (set! *macros* (cons ,name *macros*)))) + + +(define (defmacro? m) (and (memv m *macros*) #t)) + +(define macroexpand-1 MACRO-EXPAND-1) +(define macroexpand MACRO-EXPAND) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define gentemp GENSYM) +(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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;;; define an error procedure for the library +(define (slib:error . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (error (apply string-append (map (lambda (x) (format #f " ~a" x)) args)))) + + +;;; define these as appropriate for your system. +(define slib:tab (integer->char 9)) +(define slib:form-feed (integer->char 12)) + +;;; Define these if your implementation's syntax can support it and if +;;; they are not already defined. +(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 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) + +;;; (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) + +;;; +;;; Retain original require/provide before loading "require.scm" +;;; +(define stk:require require) +(define stk:provide provide) +(define stk:provided? provided?) + +(define slib:load slib:load-source) +(slib:load (in-vicinity (library-vicinity) "require")) + + +;;; +;;; Redefine require/provide so that symbols use SLIB one and strings use STk one +;;; + +(define require + (let ((slib:require require)) + (lambda (item) + ((if (symbol? item) slib:require stk:require) item )))) + +(define provide + (let ((slib:provide provide)) + (lambda (item) + ((if (symbol? item) slib:provide stk:provide) item)))) + +(define provided? + (let ((slib:provided? provided?)) + (lambda (item) + ((if (symbol? item) slib:provided? stk:provided?) item)))) + +(define identity (lambda (x) x)) diff --git a/module/slib/Template.scm b/module/slib/Template.scm new file mode 100644 index 000000000..aa8862718 --- /dev/null +++ b/module/slib/Template.scm @@ -0,0 +1,282 @@ +;;; "Template.scm" configuration template of *features* for Scheme -*-scheme-*- +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. + +;;; (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-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) #f) + +;;; (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))) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define home-vicinity + (let ((home-path (getenv "HOME"))) + (lambda () home-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 ;R5RS two-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. + +;;; "rationalize" adjunct procedures. +;;(define (find-ratio x e) +;; (let ((rat (rationalize x e))) +;; (list (numerator rat) (denominator rat)))) +;;(define (find-ratio-between x y) +;; (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; 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) + +;;; 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 (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 (defmacro:load <pathname>) + (slib:eval-load <pathname> defmacro:eval)) + +(define slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;;; define an error procedure for the library +(define (slib:error . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (apply error args)) + +;;; 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/module/slib/alist.scm b/module/slib/alist.scm new file mode 100644 index 000000000..65ddb220c --- /dev/null +++ b/module/slib/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/module/slib/alistab.scm b/module/slib/alistab.scm new file mode 100644 index 000000000..395bf0678 --- /dev/null +++ b/module/slib/alistab.scm @@ -0,0 +1,352 @@ +;;; "alistab.scm" database tables using association lists (assoc) +; Copyright 1994, 1997 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 key-dim) . TABLE) +;;; TABLE is an alist of (Primary-key . ROW) +;;; ROW is a list of non-primary VALUEs + +(require 'common-list-functions) + +(define alist-table + (let ((catalog-id 0) + (resources '*base-resources*) + (make-list-keyifier (lambda (prinum types) identity)) + (make-keyifier-1 (lambda (type) list)) + (make-key->list (lambda (prinum types) identity)) + (make-key-extractor (lambda (primary-limit column-type-list index) + (let ((i (+ -1 index))) + (lambda (lst) (list-ref lst i)))))) + +(define keyify-1 (make-keyifier-1 'atom)) + +(define (make-base filename dim types) + (list filename + (list catalog-id) + (list resources (list 'free-id 1)))) + +(define (open-base infile writable) + (and (or (input-port? infile) (file-exists? infile)) + (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 (assoc* (keyify-1 'free-id) (handle->alist free-hand))) + (table-id #f)) + (cond (row + (set! table-id (cadr row)) + (set-car! (cdr row) (+ 1 table-id)) + (set-cdr! lldb (cons (list table-id) (cdr lldb))) + table-id) + (else #f)))))) + +(define (open-table lldb base-id dim types) + (assoc base-id (cdr lldb))) + +(define (kill-table lldb base-id dim types) + (define ckey (list base-id)) + (let ((pair (assoc* ckey (cdr lldb)))) + (and pair (set-cdr! lldb (delete-assoc ckey (cdr lldb)))) + (and pair (not (assoc* ckey (cdr lldb)))))) + +(define handle->alist cdr) +(define set-handle-alist! set-cdr!) + +(define (assoc* keys alist) + (let ((pair (assoc (car keys) alist))) + (cond ((not pair) #f) + ((null? (cdr keys)) pair) + (else (assoc* (cdr keys) (cdr pair)))))) + +(define (make-assoc* keys alist vals) + (let ((pair (assoc (car keys) alist))) + (cond ((not pair) (cons (cons (car keys) + (if (null? (cdr keys)) + vals + (make-assoc* (cdr keys) '() vals))) + alist)) + (else (set-cdr! pair (if (null? (cdr keys)) + vals + (make-assoc* (cdr keys) (cdr pair) vals))) + alist)))) + +(define (delete-assoc ckey alist) + (cond + ((null? ckey) '()) + ((assoc (car ckey) alist) + => (lambda (match) + (let ((adl (delete-assoc (cdr ckey) (cdr match)))) + (cond ((null? adl) (delete match alist)) + (else (set-cdr! match adl) alist))))) + (else alist))) + +(define (delete-assoc* ckey alist) + (cond + ((every not ckey) '()) ;includes the null case. + ((not (car ckey)) + (delete '() + (map (lambda (fodder) + (let ((adl (delete-assoc* (cdr ckey) (cdr fodder)))) + (if (null? adl) '() (cons (car fodder) adl)))) + alist))) + ((procedure? (car ckey)) + (delete '() + (map (lambda (fodder) + (if ((car ckey) (car fodder)) + (let ((adl (delete-assoc* (cdr ckey) (cdr fodder)))) + (if (null? adl) '() (cons (car fodder) adl))) + fodder)) + alist))) + ((assoc (car ckey) alist) + => (lambda (match) + (let ((adl (delete-assoc* (cdr ckey) (cdr match)))) + (cond ((null? adl) (delete match alist)) + (else (set-cdr! match adl) alist))))) + (else alist))) + +(define (assoc*-for-each proc bkey ckey alist) + (cond ((null? ckey) (proc (reverse bkey))) + ((not (car ckey)) + (for-each (lambda (alist) + (assoc*-for-each proc + (cons (car alist) bkey) + (cdr ckey) + (cdr alist))) + alist)) + ((procedure? (car ckey)) + (for-each (lambda (alist) + (if ((car ckey) (car alist)) + (assoc*-for-each proc + (cons (car alist) bkey) + (cdr ckey) + (cdr alist)))) + alist)) + ((assoc (car ckey) alist) + => (lambda (match) + (assoc*-for-each proc + (cons (car match) bkey) + (cdr ckey) + (cdr match)))))) + +(define (assoc*-map proc bkey ckey alist) + (cond ((null? ckey) (list (proc (reverse bkey)))) + ((not (car ckey)) + (apply append + (map (lambda (alist) + (assoc*-map proc + (cons (car alist) bkey) + (cdr ckey) + (cdr alist))) + alist))) + ((procedure? (car ckey)) + (apply append + (map (lambda (alist) + (if ((car ckey) (car alist)) + (assoc*-map proc + (cons (car alist) bkey) + (cdr ckey) + (cdr alist)) + '())) + alist))) + ((assoc (car ckey) alist) + => (lambda (match) + (assoc*-map proc + (cons (car match) bkey) + (cdr ckey) + (cdr match)))) + (else '()))) + +(define (sorted-assoc*-for-each proc bkey ckey alist) + (cond ((null? ckey) (proc (reverse bkey))) + ((not (car ckey)) + (for-each (lambda (alist) + (sorted-assoc*-for-each proc + (cons (car alist) bkey) + (cdr ckey) + (cdr alist))) + (alist-sort! alist))) + ((procedure? (car ckey)) + (sorted-assoc*-for-each proc + bkey + (cons #f (cdr ckey)) + (remove-if-not (lambda (pair) + ((car ckey) (car pair))) + alist))) + ((assoc (car ckey) alist) + => (lambda (match) + (sorted-assoc*-for-each proc + (cons (car match) bkey) + (cdr ckey) + (cdr match)))))) + +(define (alist-sort! alist) + (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) + (map cdr (sort! (map (lambda (p) + (cons (key->sortable (car p)) p)) + alist) + car-key-<))) + +(define (present? handle ckey) + (assoc* ckey (handle->alist handle))) + +(define (make-putter prinum types) + (lambda (handle ckey restcols) + (set-handle-alist! handle + (make-assoc* ckey (handle->alist handle) restcols)))) + +(define (make-getter prinum types) + (lambda (handle ckey) + (let ((row (assoc* ckey (handle->alist handle)))) + (and row (cdr row))))) + +(define (for-each-key handle operation primary-limit column-type-list match-keys) + (assoc*-for-each operation + '() + match-keys + (handle->alist handle))) + +(define (map-key handle operation primary-limit column-type-list match-keys) + (assoc*-map operation + '() + match-keys + (handle->alist handle))) + +(define (ordered-for-each-key handle operation + primary-limit column-type-list match-keys) + (sorted-assoc*-for-each operation + '() + match-keys + (handle->alist handle))) + +(define (supported-type? type) + (case type + ((base-id atom integer boolean string symbol expression number) #t) + (else #f))) + +(define (supported-key-type? type) + (case type + ((atom integer number symbol string) #t) + (else #f))) + +;;make-table open-table remover assoc* make-assoc* +;;(trace assoc*-for-each assoc*-map sorted-assoc*-for-each) + + (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) + ((catalog-id) catalog-id) + ((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) + (lambda (handle ckey) + (set-handle-alist! handle + (delete-assoc ckey (handle->alist handle))))) + ((delete*) + (lambda (handle primary-limit column-type-list match-keys) + (set-handle-alist! handle + (delete-assoc* match-keys + (handle->alist handle))))) + ((for-each-key) for-each-key) + ((map-key) map-key) + ((ordered-for-each-key) ordered-for-each-key) + (else #f))) + )) + +;; #f (trace-all "/home/jaffer/slib/alistab.scm") (untrace alist-table) (set! *qp-width* 333) diff --git a/module/slib/array.scm b/module/slib/array.scm new file mode 100644 index 000000000..08b8114bc --- /dev/null +++ b/module/slib/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)) (+ 1 (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/module/slib/arraymap.scm b/module/slib/arraymap.scm new file mode 100644 index 000000000..ab3d7c835 --- /dev/null +++ b/module/slib/arraymap.scm @@ -0,0 +1,78 @@ +;;;; "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 (array-index-map! ra fun) + (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! ra (apply fun is) is)) + (let ((crshape (cdr rshape)) + (ll (caar rshape))) + (do ((i (cadar rshape) (+ -1 i))) + ((< i ll)) + (ramap crshape (cons i inds)))))) + (if (zero? (array-rank ra)) + (array-set! ra (fun)) + (ramap (reverse (array-shape ra)) '()))) + +(define (array-indexes ra) + (let ((ra0 (apply make-array '() (array-shape ra)))) + (array-index-map! ra0 list) + ra0)) + +(define (array-copy! source dest) + (array-map! dest identity source)) diff --git a/module/slib/batch.scm b/module/slib/batch.scm new file mode 100644 index 000000000..d77519dcb --- /dev/null +++ b/module/slib/batch.scm @@ -0,0 +1,454 @@ +;;; "batch.scm" Group and execute commands on various systems. +;Copyright (C) 1994, 1995, 1997 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) +(require 'string-port) +(require 'tree) + +(define system + (if (provided? 'system) + system + (lambda (str) 1))) +(define system:success? + (case (software-type) + ((VMS) (lambda (int) (eqv? 1 int))) + (else zero?))) +;;(trace system system:success? exit quit slib:exit) + +(define (batch:port parms) + (let ((bp (parameter-list-ref parms 'batch-port))) + (cond ((or (not (pair? bp)) (not (output-port? (car bp)))) + (slib:warn 'batch-line "missing batch-port parameter" bp) + (current-output-port)) + (else (car bp))))) + +(define (batch:dialect parms) ; was batch-family + (car (parameter-list-ref parms 'batch-dialect))) + +(define (write-batch-line str line-limit port) + (cond ((and line-limit (>= (string-length str) line-limit)) + (slib:warn 'write-batch-line 'too-long + (string-length str) '> line-limit) + #f) + (else (write-line str port) #t))) +(define (batch-line parms str) + (write-batch-line str (batch:line-length-limit parms) (batch:port parms))) + +;;; add a Scheme batch-dialect? + +(define (batch:try-chopped-command parms . args) + (define args-but-last (batch:flatten (butlast args 1))) + (define line-limit (batch:line-length-limit parms)) + (let loop ((fodder (car (last-pair args)))) + (let ((str (batch:glued-line parms + (batch:flatten + (append args-but-last (list fodder)))))) + (cond ((< (string-length str) line-limit) + (batch:try-command parms str)) + ((< (length fodder) 2) + (slib:warn 'batch:try-chopped-command "can't fit in " line-limit + (cons proc (append args-but-last (list fodder)))) + #f) + (else (let ((hlen (quotient (length fodder) 2))) + (and (loop (last fodder hlen)) + (loop (butlast fodder hlen))))))))) + +(define (batch:glued-line parms strings) + (case (batch:dialect parms) + ((vms) (apply string-join " " "$" strings)) + ((unix dos amigados system *unknown*) (apply string-join " " strings)) + (else #f))) + +(define (batch:try-command parms . strings) + (set! strings (batch:flatten strings)) + (let ((line (batch:glued-line parms strings))) + (and line + (case (batch:dialect parms) + ((unix dos vms amigados) (batch-line parms line)) + ((system) + (let ((port (batch:port parms))) + (write `(system ,line) port) (newline port) + (and (provided? 'system) (system:success? (system line))))) + ((*unknown*) + (let ((port (batch:port parms))) + (write `(system ,line) port) (newline port) #t)) + (else #f))))) + +(define (batch:command parms . strings) + (cond ((apply batch:try-command parms strings)) + (else (slib:error 'batch:command 'failed strings)))) + +(define (batch:run-script parms name . strings) + (case (batch:dialect parms strings) + ((vms) (batch:command parms (string-append "@" name) strings)) + (else (batch:command parms name strings)))) + +(define (batch:write-comment-line dialect line port) + (case dialect + ((unix) (write-batch-line (string-append "# " line) #f port)) + ((dos) (write-batch-line (string-append "rem " line) #f port)) + ((vms) (write-batch-line (string-append "$! " line) #f port)) + ((amigados) (write-batch-line (string-append "; " line) #f port)) + ((system) (write-batch-line (string-append "; " line) #f port)) + ((*unknown*) (write-batch-line (string-append ";;; " line) #f port) + ;;(newline port) + #f))) + +(define (batch:comment parms . lines) + (define port (batch:port parms)) + (define dialect (batch:dialect parms)) + (set! lines (batch:flatten lines)) + (every (lambda (line) + (batch:write-comment-line dialect line port)) + lines)) + +(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")))) + ((amigados) (batch-line parms (string-append "delete force " file)) + (every + (lambda (str) + (letrec ((star-quote + (lambda (str) + (if (equal? "" str) + str + (let* ((ch (string-ref str 0)) + (s (if (char=? ch #\") + (string #\* ch) + (string ch)))) + (string-append + s + (star-quote + (substring str 1 (string-length str))))))))) + (batch-line parms (string-append "echo \"" (star-quote str) + "\" >> " file)))) + lines)) + ((system) (write `(delete-file ,file) port) (newline port) + (delete-file file) + (require 'pretty-print) + (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) + (require 'pretty-print) + (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) + ((amigados) (batch-line parms (string-append "delete force " 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 " " "REN" 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))) + ((amigados) (batch-line parms (string-join " " "failat 21")) + (batch-line parms (string-join " " "delete force" new-name)) + (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:write-header-comment dialect name port) + (batch:write-comment-line + dialect + (string-append (if (string? name) + (string-append "\"" name "\"") + (case dialect + ((system *unknown*) "Scheme") + ((vms) "VMS") + ((dos) "DOS") + ((default-for-platform) "??") + (else (symbol->string dialect)))) + " script created by SLIB/batch " + (cond ((provided? 'bignum) + (require 'posix-time) + (let ((ct (ctime (current-time)))) + (substring ct 0 (+ -1 (string-length ct))))) + (else ""))) + port)) + +(define (batch:call-with-output-script parms name proc) + (define dialect (batch:dialect parms)) + (case dialect + ((unix) ((cond ((and (string? name) (provided? 'system)) + (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) + (batch:write-header-comment dialect name 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) + (batch:write-header-comment dialect name 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) + (batch:write-header-comment dialect name port) + ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port) + (proc port)))) + + ((amigados) ((cond ((and (string? name) (provided? 'system)) + (lambda (proc) + (let ((ans (call-with-output-file name proc))) + (system (string-append "protect " name " rswd")) + ans))) + ((output-port? name) (lambda (proc) (proc name))) + (else (lambda (proc) (proc (current-output-port))))) + (lambda (port) + (batch:write-header-comment dialect name port) + (proc port)))) + + ((system) ((cond ((and (string? name) (provided? 'system)) + (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) + (batch:write-header-comment dialect name port) + (proc port)))) + + ((*unknown*) ((cond ((and (string? name) (provided? 'system)) + (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) + (batch:write-header-comment dialect name port) + (proc port)))))) + +;;; 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)) + ((not (provided? 'system)) #f) + (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 (truncate-up-to str chars) + (define (tut str) + (do ((i (string-length str) (+ -1 i))) + ((or (zero? i) (memv (string-ref str (+ -1 i)) chars)) + (substring str i (string-length str))))) + (cond ((char? chars) (set! chars (list chars))) + ((string? chars) (set! chars (string->list chars)))) + (if (string? str) (tut str) (map tut 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 #f) +(define batch-dialect->line-length-limit #f) + +(define (batch:line-length-limit parms) + (let ((bl (parameter-list-ref parms 'batch-line-length-limit))) + (if bl (car bl) (batch-dialect->line-length-limit (batch:dialect parms))))) + +(define (batch:initialize! database) + (set! batch:database database) + (define-tables database + + '(batch-dialect + ((family atom)) + ((line-length-limit number)) + ((unix 1023) + (dos 127) + (vms 1023) + (amigados 511) + (system 1023) + (*unknown* -1))) + + '(operating-system + ((name symbol)) + ((os-family batch-dialect)) + (;;(3b1 *unknown*) + (*unknown* *unknown*) + (acorn *unknown*) + (aix unix) + (alliant *unknown*) + (amiga amigados) + (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*) + (irix unix) + (isis *unknown*) + (linux unix) + (mac *unknown*) + (masscomp unix) + (mips *unknown*) + (ms-dos dos) + (ncr *unknown*) + (newton *unknown*) + (next unix) + (novell *unknown*) + (os/2 dos) + (osf1 unix) + (prime *unknown*) + (psion *unknown*) + (pyramid *unknown*) + (sequent *unknown*) + (sgi *unknown*) + (stratus *unknown*) + (sunos unix) + (transputer *unknown*) + (unicos unix) + (unix unix) + (vms vms) + ))) + + ((database 'add-domain) '(operating-system operating-system #f symbol #f)) + (set! os->batch-dialect (((batch:database 'open-table) 'operating-system #f) + 'get 'os-family)) + (set! batch-dialect->line-length-limit + (((batch:database 'open-table) 'batch-dialect #f) + 'get 'line-length-limit)) + ) diff --git a/module/slib/bigloo.init b/module/slib/bigloo.init new file mode 100644 index 000000000..211979b86 --- /dev/null +++ b/module/slib/bigloo.init @@ -0,0 +1,263 @@ +;; "bigloo.init" Initialization for SLIB for Bigloo -*-scheme-*- +;; Copyright 1994 Robert Sanders +;; 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. + +(define (software-type) 'UNIX) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. + +(define (scheme-implementation-type) 'Bigloo) + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +;;; (scheme-implementation-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) + "http://kaolin.unice.fr/~serrano/bigloo/bigloo.html") + +(define (scheme-implementation-version) "2.0c") + +;;; (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/unsup/lib/bigloo/") + ((VMS) "scheme$src:") + ((MSDOS) "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) "/home/bambam/leavens/unsup-src/scheme/scm/slib/") + ((VMS) "lib$scheme:") + ((MSDOS) "C:\\SLIB\\") + (else ""))))) + (lambda () library-path))) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define home-vicinity + (let ((home-path (getenv "HOME"))) + (lambda () home-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") + rev4-report ;conforms to + rev3-report ;conforms to + ieee-p1178 ;conforms to + rev4-optional-procedures + rev3-procedures + multiarg/and- + multiarg-apply + rationalize + object-hash + delay + promise + with-file + transcript + ieee-floating-point + eval + pretty-print + object->string + string-case + string-port + system + getenv + defmacro + ;;full-continuation ;not without the -call/cc switch + )) + +(define pretty-print pp) + +(define (object->string x) (obj->string x)) + +;;; 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+) + +;;; (OUTPUT-PORT-WIDTH <port>) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT <port>) +(define (output-port-height . arg) 24) + +;;; (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 . args) + (flush-output-port (if (pair? args) (car args) (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 f) + (let ((outsp (open-output-string))) + (f outsp) + (close-output-port outsp))) + +(define (call-with-input-string s f) + (let* ((insp (open-input-string s)) + (res (f insp))) + (close-input-port insp) + res)) + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; 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) + +;; define an error procedure for the library + +;;; If your implementation provides eval, SLIB:EVAL is single argument +;;; eval using the top-level (user) environment. +(define slib:eval eval) + +(define-macro (defmacro name . forms) + `(define-macro (,name . ,(car forms)) ,@(cdr forms))) + +(define (defmacro? m) (get-eval-expander m)) +(define (macroexpand-1 body) (expand-once body)) +(define (macroexpand body) (expand body)) + +(define (gentemp) (gensym)) + +(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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +(define (slib:error . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (error 'slib:error "" args)) + +;; define these as appropriate for your system. +(define slib:tab (integer->char 9)) +(define slib:form-feed (integer->char 12)) + +;;; records +(defmacro define-record forms + (let* ((name (car forms)) + (maker-name (symbol-append 'make- name))) + `(begin + (define-struct ,name ,@(cadr forms)) + (define ,maker-name ,name)) + )) + + +(define (promise:force p) (force p)) + +;;; (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 0))) + +;;; 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) (loadq (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 loadq) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) + +(define defmacro:eval slib:eval) +(define defmacro:load slib:load) + +;;; If your implementation provides R4RS macros: +;(define macro:eval slib:eval) +;(define macro:load load) + +(slib:load (in-vicinity (library-vicinity) "require")) +; eof diff --git a/module/slib/break.scm b/module/slib/break.scm new file mode 100644 index 000000000..ae92d407d --- /dev/null +++ b/module/slib/break.scm @@ -0,0 +1,149 @@ +;;;; "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 + (if (provided? 'trace) (print-call-stack (current-error-port))) + (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 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! trace: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 (unbreakf function) + ;; (set! trace: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 (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) + (unbreakf fun)) + (else fun)))) + +;;;; 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/module/slib/byte.scm b/module/slib/byte.scm new file mode 100644 index 000000000..b34816da5 --- /dev/null +++ b/module/slib/byte.scm @@ -0,0 +1,15 @@ +;;; "byte.scm" small integers, not necessarily chars. + +(define (byte-ref str ind) (char->integer (string-ref str ind))) +(define (byte-set! str ind val) (string-set! str ind (integer->char val))) +(define (make-bytes len . opt) + (if (null? opt) (make-string len) + (make-string len (integer->char (car opt))))) +(define bytes-length string-length) +(define (write-byte byt . opt) (apply write-char (integer->char byt) opt)) +(define (read-byte . opt) + (let ((c (apply read-char opt))) + (if (eof-object? c) c (char->integer c)))) +(define (bytes . args) (list->bytes args)) +(define (bytes->list bts) (map char->integer (string->list bts))) +(define (list->bytes lst) (list->string (map integer->char lst))) diff --git a/module/slib/chap.scm b/module/slib/chap.scm new file mode 100644 index 000000000..6a20aebf3 --- /dev/null +++ b/module/slib/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/module/slib/charplot.scm b/module/slib/charplot.scm new file mode 100644 index 000000000..331bceb4f --- /dev/null +++ b/module/slib/charplot.scm @@ -0,0 +1,171 @@ +;;;; "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) +(require 'printf) +(require 'array) +(require 'array-for-each) + +(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 (charplot:number->string x) + (sprintf #f "%g" x)) + +(define (charplot: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 (charplot:find-scale isize delta) + (define (fs2) + (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))) + (cond ((zero? delta) (set! delta 1)) + ((inexact? delta) (set! isize (exact->inexact isize)))) + (do ((d 1 (* d 10))) + ((<= delta isize) + (do ((n 1 (* n 10))) + ((>= (* delta 10) isize) + (list (* n (fs2)) d)) + (set! delta (* delta 10)))) + (set! isize (* isize 10)))) + +(define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale) + (define xaxis (- (charplot:scale-it ymin yscale))) + (define yaxis (- (charplot: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 (charplot: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 charplot:width)) + (charplot:center-print! (charplot:number->string + (/ (* (- i yaxis) (cadr xscale)) + (car xscale))) + xstep)) + (newline))) + +(define (charplot:plot! data xlabel ylabel) + (cond ((array? data) + (case (array-rank data) + ((1) (set! data (map cons + (let ((ra (apply make-array #f + (array-shape data)))) + (array-index-map! ra identity) + (array->list ra)) + (array->list data)))) + ((2) (set! data (map (lambda (lst) (cons (car lst) (cadr lst))) + (array->list data))))))) + (let* ((xmax (apply max (map car data))) + (xmin (apply min (map car data))) + (xscale (charplot:find-scale charplot:width (- xmax xmin))) + (ymax (apply max (map cdr data))) + (ymin (apply min (map cdr data))) + (yscale (charplot:find-scale charplot:height (- ymax ymin))) + (ixmin (charplot:scale-it xmin xscale)) + (iymin (charplot:scale-it ymin yscale))) + (charplot:iplot! (map (lambda (p) + (cons (- (charplot:scale-it (car p) xscale) ixmin) + (- (charplot:scale-it (cdr p) yscale) iymin))) + data) + xlabel ylabel xmin xscale ymin yscale))) + +(define (plot-function! func vlo vhi . npts) + (set! npts (if (null? npts) 100 (car npts))) + (let ((dats (make-array 0.0 npts 2))) + (array-index-map! (make-shared-array dats (lambda (idx) (list idx 0)) npts) + (lambda (idx) (+ vlo (* (- vhi vlo) (/ idx npts))))) + (array-map! (make-shared-array dats (lambda (idx) (list idx 1)) npts) + func + (make-shared-array dats (lambda (idx) (list idx 0)) npts)) + (charplot:plot! dats "" ""))) + +(define plot! charplot:plot!) diff --git a/module/slib/chez.init b/module/slib/chez.init new file mode 100644 index 000000000..d5cdbb539 --- /dev/null +++ b/module/slib/chez.init @@ -0,0 +1,396 @@ +;;;"chez.init" Initialization file for SLIB for Chez Scheme 6.0a -*-scheme-*- +;;; Authors: dorai@cs.rice.edu (Dorai Sitaram) and Aubrey Jaffer. +;;; +;;; This code is in the public domain. + +;;; Adapted to version 5.0c by stone@math.grin.edu (John David Stone) 1997 +;;; Adapted to version 6.0a by Gary T. Leavens <leavens@cs.iastate.edu>, 1999 + +;;; (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) 'chez) + +;;; (scheme-implementation-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) + "http://www.cs.indiana.edu/chezscheme/") + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "6.0a") + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. + +(define implementation-vicinity + (lambda () "/usr/unsup/scheme/chez/")) + +;;; (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))) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define home-vicinity + (let ((home-path (getenv "HOME"))) + (lambda () home-path))) + +;;; *FEATURES* should be set to a list of symbols describing features +;;; of this implementation. Suggestions for features are: + +(define *features* + '( + source ; Chez Scheme can load Scheme source files, with the + ; command (slib:load-source "filename") -- see below. + + compiled ; Chez Scheme can also load compiled Scheme files, with the + ; command (slib:load-compiled "filename") -- see below. + 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 ;R5RS two-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 + fluid-let + random + rev3-procedures + )) + +;;; (OUTPUT-PORT-WIDTH <port>) returns the number of graphic characters +;;; that can reliably be displayed on one line of the standard output port. + +(define output-port-width + (lambda arg + (let ((env-width-string (getenv "COLUMNS"))) + (if (and env-width-string + (let loop ((remaining (string-length env-width-string))) + (or (zero? remaining) + (let ((next (- remaining 1))) + (and (char-numeric? (string-ref env-width-string + next)) + (loop next)))))) + (- (string->number env-width-string) 1) + 79)))) + +;;; (OUTPUT-PORT-HEIGHT <port>) returns the number of lines of text that +;;; can reliably be displayed simultaneously in the standard output port. + +(define output-port-height + (lambda arg + (let ((env-height-string (getenv "LINES"))) + (if (and env-height-string + (let loop ((remaining (string-length env-height-string))) + (or (zero? remaining) + (let ((next (- remaining 1))) + (and (char-numeric? (string-ref env-height-string + next)) + (loop next)))))) + (string->number env-height-string) + 24)))) + +;;; (CURRENT-ERROR-PORT) +(define current-error-port + (let ((port (console-output-port))) ; changed from 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>) is built-in to Chez Scheme + +;;; (DELETE-FILE <string>) is built-in to Chez Scheme + +;; The FORCE-OUTPUT requires buffered output that has been written to a +;; port to be transferred all the way out to its ultimate destination. +(define force-output flush-output-port) + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; 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 +;; 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) + +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. +(define slib:eval eval) + +;;; define an error procedure for the library +(define slib:error + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Error: " cep) + (for-each (lambda (x) (display x cep)) args) + (error #f "")))) + +;;; define these as appropriate for your system. +(define slib:tab #\tab) +(define slib:form-feed #\page) + +;;; Support for older versions of Scheme. Not enough code for its own file. +;;; last-pair is built-in to Chez Scheme +(define t #t) +(define nil #f) + +;;; Define these if your implementation's syntax can support it and if +;;; they are not already defined. +;;; 1+, -1+, and 1- are built-in to Chez Scheme +;(define (1+ n) (+ n 1)) +;(define (-1+ n) (+ n -1)) +;(define 1- -1+) + +;;; (IN-VICINITY <string>) is simply STRING-APPEND, conventionally used +;;; to attach a directory pathname to the name of a file that is expected to +;;; be in that directory. +(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 identity))) + (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))))) + +;;; For backward compatability, the SCHEME-FILE-SUFFIX procedure is defined +;;; to return the string ".scm". Note, however, that ".ss" is a common Chez +;;; file suffix. +(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) + +;;; The following make procedures in Chez Scheme compatible with +;;; the assumptions of SLIB. + +;;; Chez's sorting routines take parameters in the order opposite to SLIB's. +;;; The following definitions override the predefined procedures with the +;;; parameters-reversed versions. See the SORT feature. + +(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))) + +;;; Chez's (FORMAT F . A) corresponds to SLIB's (FORMAT #F F . A) +;;; See the FORMAT feature. + +(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)))))) + +;; The following definitions implement a few widely useful procedures that +;; Chez Scheme does not provide or provides under a different name. + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-INPUT-FILE and CALL-WITH-OUTPUT-FILE. +;;; See the STRING-PORT feature. + +(define call-with-output-string + (lambda (f) + (let ((outsp (open-output-string))) + (f outsp) + (let ((s (get-output-string outsp))) + (close-output-port outsp) + s)))) + +(define call-with-input-string + (lambda (s f) + (let* ((insp (open-input-string s)) + (res (f insp))) + (close-input-port insp) + res))) + +;;; If your implementation provides R4RS macros: +(define macro:eval slib:eval) +;;; macro:load also needs the default suffix. +(define macro:load slib:load-source) + +(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)) + +;;; According to Kent Dybvig, you can improve the Chez Scheme init +;;; file by defining gentemp to be gensym in Chez Scheme. +(define gentemp gensym) + +(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 (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 (defmacro:load <pathname>) + (slib:eval-load <pathname> defmacro:eval)) + +(define slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;;; Load the REQUIRE package. + +(slib:load (in-vicinity (library-vicinity) "require")) + +;; end of chez.init diff --git a/module/slib/cltime.scm b/module/slib/cltime.scm new file mode 100644 index 000000000..441e7f985 --- /dev/null +++ b/module/slib/cltime.scm @@ -0,0 +1,67 @@ +;;;; "cltime.scm" Common-Lisp time conversion routines. +;;; Copyright (C) 1994, 1997 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 'time-zone) +(require 'posix-time) + +(define time:1900 (time:invert time:gmtime '#(0 0 0 1 0 0 #f #f 0 0 "GMT"))) + +(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 ((tv (apply time:split + (offset-time time:1900 utime) + (if (null? tzarg) + (tz:params utime (tzset)) + (list 0 (* 3600 (car tzarg)) "???"))))) + (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 (encode-universal-time second minute hour date month year . tzarg) + (let* ((tz (if (null? tzarg) + (tzset) + (time-zone (string-append + "???" (number->string (car tzarg)))))) + (tv (vector second + minute + hour + date + (+ -1 month) + (+ -1900 year) + #f ;ignored + #f ;ignored + ))) + (difftime (time:invert localtime tv) time:1900))) + diff --git a/module/slib/coerce.scm b/module/slib/coerce.scm new file mode 100644 index 000000000..b2e58a770 --- /dev/null +++ b/module/slib/coerce.scm @@ -0,0 +1,107 @@ +;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF. +; Copyright (C) 1995, 2001 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. + +;;@body +;;Returns a symbol name for the type of @1. +(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 '?))) + +;;@body +;;Converts and returns @1 of type @code{char}, @code{number}, +;;@code{string}, @code{symbol}, @code{list}, or @code{vector} to +;;@2 (which must be one of these symbols). +(define (coerce obj result-type) + (define (err) (slib:error 'coerce 'not 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 integer) (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) + ((integer) 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 integer) (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 integer) (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 integer) + (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 integer) + (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)))))) diff --git a/module/slib/coerce.txi b/module/slib/coerce.txi new file mode 100644 index 000000000..4b7f6b0ad --- /dev/null +++ b/module/slib/coerce.txi @@ -0,0 +1,12 @@ + +@defun type-of obj + +Returns a symbol name for the type of @var{obj}. +@end defun + +@defun coerce obj result-type + +Converts and returns @var{obj} 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 diff --git a/module/slib/collect.scm b/module/slib/collect.scm new file mode 100644 index 000000000..35a333d4e --- /dev/null +++ b/module/slib/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/module/slib/comlist.scm b/module/slib/comlist.scm new file mode 100644 index 000000000..bea99a70a --- /dev/null +++ b/module/slib/comlist.scm @@ -0,0 +1,328 @@ +;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme +; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer. +; Copyright (C) 2000 Colin Walters +; +;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 + +;;; Some tail-recursive optimizations made by +;;; Colin Walters <walters@cis.ohio-state.edu> + +;;;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 (memv 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) + ;; optimization + (if (null? l2) + l2 + (let build-intersection ((l1 l1) + (result '())) + (cond ((null? l1) + result) + ((memv (car l1) l2) (build-intersection (cdr l1) (cons (car l1) result))) + (else (build-intersection (cdr l1) result)))))) + +(define (comlist:set-difference l1 l2) + ;; optimization + (if (null? l2) + l1 + (let build-difference ((l1 l1) + (result '())) + (cond ((null? l1) + result) + ((memv (car l1) l2) (build-difference (cdr l1) result)) + (else (build-difference (cdr l1) (cons (car l1) result))))))) + +(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:list-of?? predicate . bound) + (define (errout) (apply slib:error 'list-of?? predicate bound)) + (case (length bound) + ((0) + (lambda (obj) + (and (list? obj) + (every predicate obj)))) + ((1) + (set! bound (car bound)) + (cond ((negative? bound) + (set! bound (- bound)) + (lambda (obj) + (and (list? obj) + (<= bound (length obj)) + (every predicate obj)))) + (else + (lambda (obj) + (and (list? obj) + (<= (length obj) bound) + (every predicate obj)))))) + ((2) + (let ((low (car bound)) + (high (cadr bound))) + (cond ((or (negative? low) (negative? high)) (errout)) + ((< high low) + (set! high (car bound)) + (set! low (cadr bound)))) + (lambda (obj) + (and (list? obj) + (<= low (length obj) high) + (every predicate obj))))) + (else (errout)))) + +(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) + (let remove ((l l) + (result '())) + (cond ((null? l) result) + ((eqv? p (car l)) (remove (cdr l) result)) + (else (remove (cdr l) (cons (car l) result)))))) + +(define (comlist:remove-if p l) + (let remove-if ((l l) + (result '())) + (cond ((null? l) result) + ((p (car l)) (remove-if (cdr l) result)) + (else (remove-if (cdr l) (cons (car l) result)))))) + +(define (comlist:remove-if-not p l) + (let remove-if-not ((l l) + (result '())) + (cond ((null? l) result) + ((p (car l)) (remove-if-not (cdr l) (cons (car l) result))) + (else (remove-if-not (cdr l) result))))) + +(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:last lst n) + (comlist:nthcdr (- (length lst) n) lst)) + +(define (comlist:butlast lst n) + (letrec ((l (- (length lst) n)) + (bl (lambda (lst n) + (let build-until-zero ((lst lst) + (n n) + (result '())) + (cond ((null? lst) (reverse result)) + ((positive? n) + (build-until-zero (cdr lst) (- n 1) (cons (car lst) result))) + (else (reverse result))))))) + (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:butnthcdr n lst) + (letrec ((bl (lambda (lst n) + (let build-until-zero ((lst lst) + (n n) + (result '())) + (cond ((null? lst) (reverse result)) + ((positive? n) + (build-until-zero (cdr lst) (- n 1) (cons (car lst) result))) + (else (reverse result))))))) + (bl lst (if (negative? n) + (slib:error "negative argument to butnthcdr" n) + n)))) + +;;;; 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 duplicate MEMBERs. +(define (comlist:has-duplicates? lst) + (cond ((null? lst) #f) + ((member (car lst) (cdr lst)) #t) + (else (comlist:has-duplicates? (cdr lst))))) + +;;; remove duplicates of MEMBERs of a list +(define (comlist:remove-duplicates lst) + (letrec ((rem-dup + (lambda (lst nlst) + (cond ((null? lst) nlst) + ((member (car lst) nlst) (rem-dup (cdr lst) nlst)) + (else (rem-dup (cdr lst) (cons (car lst) nlst))))))) + (rem-dup 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 (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 last comlist:last) +(define butlast comlist:butlast) +(define nthcdr comlist:nthcdr) +(define butnthcdr comlist:butnthcdr) +(define and? comlist:and?) +(define or? comlist:or?) +(define has-duplicates? comlist:has-duplicates?) +(define remove-duplicates comlist:remove-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*) +(define list-of?? comlist:list-of??) diff --git a/module/slib/comparse.scm b/module/slib/comparse.scm new file mode 100644 index 000000000..9066e36a7 --- /dev/null +++ b/module/slib/comparse.scm @@ -0,0 +1,99 @@ +;;; "comparse.scm" Break command line into arguments. +;Copyright (C) 1995, 1997 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. + +;;; Albert L. Ting points out that a similar process can be used for +;;; reading files of options -- therefore READ-OPTIONS-FILE. + +(require 'string-port) +(define (read-command-from-port port nl-term?) + (define argv '()) + (define obj "") + (define chars '()) + (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 + (lambda (goto) + (readc) + (let ((c (readc))) + (cond ((eqv? #\newline c) (goto (peekc))) + ((and (char-whitespace? c) (eqv? #\newline (peekc)) + (eqv? 13 (char->integer c))) + (readc) (goto (peekc))) + (else (set! chars (cons c 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) (eqv? #\newline c)) + (if nl-term? c (loop (peekc)))))) + ((#\;) (readc)) + ((#\newline) (readc) (and (not nl-term?) (loop (peekc)))) + (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 buildit + (lambda () + (readc) + (set! argv (cons (string-append obj (list->string (reverse chars))) + argv)))) + (define build-token + (lambda (c) + (case c + ((#\") (splice-arg (read port))) + ((#\() (s-expression)) + ((#\\) (backslash build-token)) + ((#\;) (buildit)) + (else (cond ((or (eof-object? c) (char-whitespace? c)) + (buildit) + (cond ((not (and nl-term? (eqv? c #\newline))) + (set! obj "") + (set! chars '()) + (loop (peekc))))) + (else (set! chars (cons (readc) chars)) + (build-token (peekc)))))))) + (let ((c (loop (peekc)))) + (cond ((and (null? argv) (eof-object? c)) c) + (else (reverse argv))))) + +(define (read-command . port) + (read-command-from-port (cond ((null? port) (current-input-port)) + ((= 1 (length port)) (car port)) + (else + (slib:error 'read-command + "Wrong Number of ARGs:" port))) + #t)) + +(define (read-options-file filename) + (call-with-input-file filename + (lambda (port) (read-command-from-port port #f)))) diff --git a/module/slib/cring.scm b/module/slib/cring.scm new file mode 100644 index 000000000..320b1d2d5 --- /dev/null +++ b/module/slib/cring.scm @@ -0,0 +1,470 @@ +;;;"cring.scm" Extend Scheme numerics to any commutative ring. +;Copyright (C) 1997, 1998 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 'common-list-functions) +(require 'relational-database) +(require 'database-utilities) +(require 'sort) + +(define cring:db (create-database #f 'alist-table)) +(define (make-ruleset . rules) + (define name #f) + (cond ((and (not (null? rules)) (symbol? (car rules))) + (set! name (car rules)) + (set! rules (cdr rules))) + (else (set! name (gentemp)))) + (define-tables cring:db + (list name + '((op symbol) + (sub-op1 symbol) + (sub-op2 symbol)) + '((reduction expression)) + rules)) + (let ((table ((cring:db 'open-table) name #t))) + (and table + (list (table 'get 'reduction) + (table 'row:update) + table)))) +(define *ruleset* (make-ruleset 'default)) +(define (cring:define-rule . args) + (if *ruleset* + ((cadr *ruleset*) args) + (slib:warn "No ruleset in *ruleset*"))) + +(define (combined-rulesets . rulesets) + (define name #f) + (cond ((symbol? (car rulesets)) + (set! name (car rulesets)) + (set! rulesets (cdr rulesets))) + (else (set! name (gentemp)))) + (apply make-ruleset name + (apply append + (map (lambda (ruleset) (((caddr ruleset) 'row:retrieve*))) + rulesets)))) + +;;; Distribute * over + (and -) +(define distribute* + (make-ruleset + 'distribute* + `(* + identity + ,(lambda (exp1 exp2) + ;;(print 'distributing '* '+ exp1 exp2 '==>) + (apply + (map (lambda (trm) (* trm exp2)) (cdr exp1))))) + `(* - identity + ,(lambda (exp1 exp2) + ;;(print 'distributing '* '- exp1 exp2 '==>) + (apply - (map (lambda (trm) (* trm exp2)) (cdr exp1))))))) + +;;; Distribute / over + (and -) +(define distribute/ + (make-ruleset + 'distribute/ + `(/ + identity + ,(lambda (exp1 exp2) + ;;(print 'distributing '/ '+ exp1 exp2 '==>) + (apply + (map (lambda (trm) (/ trm exp2)) (cdr exp1))))) + `(/ - identity + ,(lambda (exp1 exp2) + ;;(print 'distributing '/ '- exp1 exp2 '==>) + (apply - (map (lambda (trm) (/ trm exp2)) (cdr exp1))))))) + +(define (symbol-alpha? sym) + (char-alphabetic? (string-ref (symbol->string sym) 0))) +(define (expression-< x y) + (cond ((and (number? x) (number? y)) (> x y)) ;want negatives last + ((number? x) #t) + ((number? y) #f) + ((and (symbol? x) (symbol? y)) + (cond ((eqv? (symbol-alpha? x) (symbol-alpha? y)) + (string<? (symbol->string x) (symbol->string y))) + (else (symbol-alpha? x)))) + ((symbol? x) #t) + ((symbol? y) #f) + ((null? x) #t) + ((null? y) #f) + ((expression-< (car x) (car y)) #t) + ((expression-< (car y) (car x)) #f) + (else (expression-< (cdr x) (cdr y))))) +(define (expression-sort seq) (sort! seq expression-<)) + +(define number* *) +(define number+ +) +(define number- -) +(define number/ /) +(define number^ integer-expt) +(define is-term-op? (lambda (term op) (and (pair? term) (eq? op (car term))))) +;;(define (sign x) (if (positive? x) 1 (if (negative? x) -1 0))) +(define number0? zero?) +(define (zero? x) (and (number? x) (number0? x))) + +;; To convert to CR internal form, NUMBER-op all the `numbers' in the +;; argument list and remove them from the argument list. Collect the +;; remaining arguments into equivalence classes, keeping track of the +;; number of arguments in each class. The returned list is thus: +;; (<numeric> (<expression1> . <exp1>) ...) + +;;; Converts * argument list to CR internal form +(define (cr*-args->fcts args) + ;;(print (cons 'cr*-args->fcts args) '==>) + (let loop ((args args) (pow 1) (nums 1) (arg.exps '())) + ;;(print (list 'loop args pow nums denoms arg.exps) '==>) + (cond ((null? args) (cons nums arg.exps)) + ((number? (car args)) + (let ((num^pow (number^ (car args) (abs pow)))) + (if (negative? pow) + (loop (cdr args) pow (number/ (number* num^pow nums)) + arg.exps) + (loop (cdr args) pow (number* num^pow nums) arg.exps)))) + ;; Associative Rule + ((is-term-op? (car args) '*) (loop (append (cdar args) (cdr args)) + pow nums arg.exps)) + ;; Do singlet - + ((and (is-term-op? (car args) '-) (= 2 (length (car args)))) + ;;(print 'got-here (car args)) + (set! arg.exps (loop (cdar args) pow (number- nums) arg.exps)) + (loop (cdr args) pow + (car arg.exps) + (cdr arg.exps))) + ((and (is-term-op? (car args) '/) (= 2 (length (car args)))) + ;; Do singlet / + ;;(print 'got-here=cr+ (car args)) + (set! arg.exps (loop (cdar args) (number- pow) nums arg.exps)) + (loop (cdr args) pow + (car arg.exps) + (cdr arg.exps))) + ((is-term-op? (car args) '/) + ;; Do multi-arg / + ;;(print 'doing '/ (cddar args) (number- pow)) + (set! arg.exps + (loop (cddar args) (number- pow) nums arg.exps)) + ;;(print 'finishing '/ (cons (cadar args) (cdr args)) pow) + (loop (cons (cadar args) (cdr args)) + pow + (car arg.exps) + (cdr arg.exps))) + ;; Pull out numeric exponents as powers + ((and (is-term-op? (car args) '^) + (= 3 (length (car args))) + (number? (caddar args))) + (set! arg.exps (loop (list (cadar args)) + (number* pow (caddar args)) + nums + arg.exps)) + (loop (cdr args) pow (car arg.exps) (cdr arg.exps))) + ;; combine with same terms + ((assoc (car args) arg.exps) + => (lambda (pair) (set-cdr! pair (number+ pow (cdr pair))) + (loop (cdr args) pow nums arg.exps))) + ;; Add new term to arg.exps + (else (loop (cdr args) pow nums + (cons (cons (car args) pow) arg.exps)))))) + +;;; Converts + argument list to CR internal form +(define (cr+-args->trms args) + (let loop ((args args) (cof 1) (numbers 0) (arg.exps '())) + (cond ((null? args) (cons numbers arg.exps)) + ((number? (car args)) + (loop (cdr args) + cof + (number+ (number* (car args) cof) numbers) + arg.exps)) + ;; Associative Rule + ((is-term-op? (car args) '+) (loop (append (cdar args) (cdr args)) + cof + numbers + arg.exps)) + ;; Idempotent singlet * + ((and (is-term-op? (car args) '*) (= 2 (length (car args)))) + (loop (cons (cadar args) (cdr args)) + cof + numbers + arg.exps)) + ((and (is-term-op? (car args) '-) (= 2 (length (car args)))) + ;; Do singlet - + (set! arg.exps (loop (cdar args) (number- cof) numbers arg.exps)) + (loop (cdr args) cof (car arg.exps) (cdr arg.exps))) + ;; Pull out numeric factors as coefficients + ((and (is-term-op? (car args) '*) (some number? (cdar args))) + ;;(print 'got-here (car args) '=> (cons '* (remove-if number? (cdar args)))) + (set! arg.exps + (loop (list (cons '* (remove-if number? (cdar args)))) + (apply number* cof (remove-if-not number? (cdar args))) + numbers + arg.exps)) + (loop (cdr args) cof (car arg.exps) (cdr arg.exps))) + ((is-term-op? (car args) '-) + ;; Do multi-arg - + (set! arg.exps (loop (cddar args) (number- cof) numbers arg.exps)) + (loop (cons (cadar args) (cdr args)) + cof + (car arg.exps) + (cdr arg.exps))) + ;; combine with same terms + ((assoc (car args) arg.exps) + => (lambda (pair) (set-cdr! pair (number+ cof (cdr pair))) + (loop (cdr args) cof numbers arg.exps))) + ;; Add new term to arg.exps + (else (loop (cdr args) cof numbers + (cons (cons (car args) cof) arg.exps)))))) + +;;; Converts + or * internal form to Scheme expression +(define (cr-terms->form op ident inv-op higher-op res.cofs) + (define (negative-cof? fct.cof) + (negative? (cdr fct.cof))) + (define (finish exprs) + (if (null? exprs) ident + (if (null? (cdr exprs)) + (car exprs) + (cons op exprs)))) + (define (do-terms sign fct.cofs) + (expression-sort + (map (lambda (fct.cof) + (define cof (number* sign (cdr fct.cof))) + (cond ((eqv? 1 cof) (car fct.cof)) + ((number? (car fct.cof)) (number* cof (car fct.cof))) + ((is-term-op? (car fct.cof) higher-op) + (if (eq? higher-op '^) + (list '^ (cadar fct.cof) (* cof (caddar fct.cof))) + (cons higher-op (cons cof (cdar fct.cof))))) + ((eqv? -1 cof) (list inv-op (car fct.cof))) + (else (list higher-op (car fct.cof) cof)))) + fct.cofs))) + (let* ((all.cofs (remove-if (lambda (fct.cof) + (or (zero? (cdr fct.cof)) + (eqv? ident (car fct.cof)))) + res.cofs)) + (cofs (map cdr all.cofs)) + (some-positive? (some positive? cofs))) + ;;(print op 'positive? some-positive? 'negative? (some negative? cofs) all.cofs) + (cond ((and some-positive? (some negative? cofs)) + (append (list inv-op + (finish (do-terms + 1 (remove-if negative-cof? all.cofs)))) + (do-terms -1 (remove-if-not negative-cof? all.cofs)))) + (some-positive? (finish (do-terms 1 all.cofs))) + ((not (some negative? cofs)) ident) + (else (list inv-op (finish (do-terms -1 all.cofs))))))) + +(define (* . args) + (cond + ((null? args) 1) + ;;This next line is commented out so ^ will collapse numerical expressions. + ;;((null? (cdr args)) (car args)) + (else + (let ((in (cr*-args->fcts args))) + (cond + ((zero? (car in)) 0) + (else + (if (null? (cdr in)) + (set-cdr! in (list (cons 1 1)))) + (let* ((num #f) + (ans (cr-terms->form + '* 1 '/ '^ + (apply + (lambda (numeric red.cofs res.cofs) + (set! num numeric) + (append + ;;(list (cons (abs numeric) 1)) + red.cofs + res.cofs)) + (cr1 '* number* '^ '/ (car in) (cdr in)))))) + (cond ((number0? (+ -1 num)) ans) + ((number? ans) (number* num ans)) + ((number0? (+ 1 num)) + (if (and (list? ans) (= 2 (length ans)) (eq? '- (car ans))) + (cadr ans) + (list '- ans))) + ((not (pair? ans)) (list '* num ans)) + (else + (case (car ans) + ((*) (append (list '* num) (cdr ans))) + ((+) (apply + (map (lambda (mon) (* num mon)) (cdr ans)))) + ((-) (apply - (map (lambda (mon) (* num mon)) (cdr ans)))) + (else (list '* num ans)))))))))))) + +(define (+ . args) + (cond ((null? args) 0) + ;;((null? (cdr args)) (car args)) + (else + (let ((in (cr+-args->trms args))) + (if (null? (cdr in)) + (car in) + (cr-terms->form + '+ 0 '- '* + (apply (lambda (numeric red.cofs res.cofs) + (append + (list (if (and (number? numeric) + (negative? numeric)) + (cons (abs numeric) -1) + (cons numeric 1))) + red.cofs + res.cofs)) + (cr1 '+ number+ '* '- (car in) (cdr in))))))))) + +(define (- arg1 . args) + (if (null? args) + (if (number? arg1) (number- arg1) + (* -1 arg1) ;(list '- arg1) + ) + (+ arg1 (* -1 (apply + args))))) + +;;(print `(/ ,arg1 ,@args) '=> ) +(define (/ arg1 . args) + (if (null? args) + (^ arg1 -1) + (* arg1 (^ (apply * args) -1)))) + +(define (^ arg1 arg2) + (cond ((and (number? arg2) (integer? arg2)) + (* (list '^ arg1 arg2))) + (else (list '^ arg1 arg2)))) + +;; TRY-EACH-PAIR-ONCE algorithm. I think this does the minimum +;; number of rule lookups given no information about how to sort +;; terms. + +;; Pick equivalence classes one at a time and move them into the +;; result set of equivalence classes by searching for rules to +;; multiply an element of the chosen class by itself (if multiple) and +;; the element of each class already in the result group. Each +;; (multiplicative) term resulting from rule application would be put +;; in the result class, if that class exists; or put in an argument +;; class if not. + +(define (cr1 op number-op hop inv-op numeric in) + (define red.pows '()) + (define res.pows '()) + (define (cring:apply-rule->terms exp1 exp2) ;(display op) + (let ((ans (cring:apply-rule op exp1 exp2))) + (cond ((not ans) #f) + ((number? ans) (list ans)) + (else (list (cons ans 1)))))) + (define (cring:apply-inv-rule->terms exp1 exp2) ;(display inv-op) + (let ((ans (cring:apply-rule inv-op exp1 exp2))) + (cond ((not ans) #f) + ((number? ans) (list ans)) + (else (list (cons ans 1)))))) + (let loop.arg.pow.s ((arg (caar in)) (pow (cdar in)) (arg.pows (cdr in))) + (define (arg-loop arg.pows) + (cond ((not (null? arg.pows)) + (loop.arg.pow.s (caar arg.pows) (cdar arg.pows) (cdr arg.pows))) + (else (list numeric red.pows res.pows)))) ; Actually return! + (define (merge-res tmp.pows multiplicity) + (cond ((null? tmp.pows)) + ((number? (car tmp.pows)) + (do ((m (number+ -1 (abs multiplicity)) (number+ -1 m)) + (n numeric (number-op n (abs (car tmp.pows))))) + ((negative? m) (set! numeric n))) + (merge-res (cdr tmp.pows) multiplicity)) + ((or (assoc (car tmp.pows) res.pows) + (assoc (car tmp.pows) arg.pows)) + => (lambda (pair) + (set-cdr! pair (number+ + pow (number-op multiplicity (cdar tmp.pows)))) + (merge-res (cdr tmp.pows) multiplicity))) + ((assoc (car tmp.pows) red.pows) + => (lambda (pair) + (set! arg.pows + (cons (cons (caar tmp.pows) + (number+ + (cdr pair) + (number* multiplicity (cdar tmp.pows)))) + arg.pows)) + (set-cdr! pair 0) + (merge-res (cdr tmp.pows) multiplicity))) + (else (set! arg.pows + (cons (cons (caar tmp.pows) + (number* multiplicity (cdar tmp.pows))) + arg.pows)) + (merge-res (cdr tmp.pows) multiplicity)))) + (define (try-fct.pow fct.pow) + ;;(print 'try-fct.pow fct.pow op 'arg arg 'pow pow) + (cond ((or (zero? (cdr fct.pow)) (number? (car fct.pow))) #f) + ((not (and (number? pow) (number? (cdr fct.pow)) + (integer? pow) ;(integer? (cdr fct.pow)) + )) + #f) + ;;((zero? pow) (slib:error "Don't try exp-0 terms") #f) + ;;((or (number? arg) (number? (car fct.pow))) + ;; (slib:error 'found-number arg fct.pow) #f) + ((and (positive? pow) (positive? (cdr fct.pow)) + (or (cring:apply-rule->terms arg (car fct.pow)) + (cring:apply-rule->terms (car fct.pow) arg))) + => (lambda (terms) + ;;(print op op terms) + (let ((multiplicity (min pow (cdr fct.pow)))) + (set-cdr! fct.pow (number- (cdr fct.pow) multiplicity)) + (set! pow (number- pow multiplicity)) + (merge-res terms multiplicity)))) + ((and (negative? pow) (negative? (cdr fct.pow)) + (or (cring:apply-rule->terms arg (car fct.pow)) + (cring:apply-rule->terms (car fct.pow) arg))) + => (lambda (terms) + ;;(print inv-op inv-op terms) + (let ((multiplicity (max pow (cdr fct.pow)))) + (set-cdr! fct.pow (number+ (cdr fct.pow) multiplicity)) + (set! pow (number+ pow multiplicity)) + (merge-res terms multiplicity)))) + ((and (positive? pow) (negative? (cdr fct.pow)) + (cring:apply-inv-rule->terms arg (car fct.pow))) + => (lambda (terms) + ;;(print op inv-op terms) + (let ((multiplicity (min pow (number- (cdr fct.pow))))) + (set-cdr! fct.pow (number+ (cdr fct.pow) multiplicity)) + (set! pow (number- pow multiplicity)) + (merge-res terms multiplicity)))) + ((and (negative? pow) (positive? (cdr fct.pow)) + (cring:apply-inv-rule->terms (car fct.pow) arg)) + => (lambda (terms) + ;;(print inv-op op terms) + (let ((multiplicity (max (number- pow) (cdr fct.pow)))) + (set-cdr! fct.pow (number- (cdr fct.pow) multiplicity)) + (set! pow (number+ pow multiplicity)) + (merge-res terms multiplicity)))) + (else #f))) + ;;(print op numeric 'arg arg 'pow pow 'arg.pows arg.pows 'red.pows red.pows 'res.pows res.pows) + ;;(trace arg-loop cring:apply-rule->terms merge-res try-fct.pow) (set! *qp-width* 333) + (cond ((or (zero? pow) (eqv? 1 arg)) ;(number? arg) arg seems to always be 1 + (arg-loop arg.pows)) + ((assoc arg res.pows) => (lambda (pair) + (set-cdr! pair (number+ pow (cdr pair))) + (arg-loop arg.pows))) + ((and (> (abs pow) 1) (cring:apply-rule->terms arg arg)) + => (lambda (terms) + (merge-res terms (quotient pow 2)) + (if (odd? pow) + (loop.arg.pow.s arg 1 arg.pows) + (arg-loop arg.pows)))) + ((or (some try-fct.pow res.pows) (some try-fct.pow arg.pows)) + (loop.arg.pow.s arg pow arg.pows)) + (else (set! res.pows (cons (cons arg pow) res.pows)) + (arg-loop arg.pows))))) + +(define (cring:try-rule op sop1 sop2 exp1 exp2) + (and *ruleset* + (let ((rule ((car *ruleset*) op sop1 sop2))) + (and rule (rule exp1 exp2))))) + +(define (cring:apply-rule op exp1 exp2) + (and (pair? exp1) + (or (and (pair? exp2) + (cring:try-rule op (car exp1) (car exp2) exp1 exp2)) + (cring:try-rule op (car exp1) 'identity exp1 exp2)))) + +;;(begin (trace cr-terms->form) (set! *qp-width* 333)) diff --git a/module/slib/db2html.scm b/module/slib/db2html.scm new file mode 100644 index 000000000..abfbc7326 --- /dev/null +++ b/module/slib/db2html.scm @@ -0,0 +1,463 @@ +;"db2html.scm" Convert relational database to hyperlinked pages. +; Copyright 1997, 1998, 2000, 2001 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 'uri) +(require 'html-form) +(require 'net-clients) +(require 'string-search) + +;;@code{(require 'db->html)} + +;;@body +(define (html:table options . rows) + (apply string-append + (sprintf #f "<TABLE %s>\\n" (or options "")) + (append rows (list (sprintf #f "</TABLE>\\n"))))) + +;;@args caption align +;;@args caption +;;@2 can be @samp{top} or @samp{bottom}. +(define (html:caption caption . align) + (if (null? align) + (sprintf #f " <CAPTION>%s</CAPTION>\\n" + (html:plain caption)) + (sprintf #f " <CAPTION ALIGN=%s>%s</CAPTION>\\n" + (car align) + (html:plain caption)))) + +;;@body Outputs a heading row for the currently-started table. +(define (html:heading columns) + (sprintf #f " <TR VALIGN=\"TOP\">\\n%s </TR>\\n" + (apply string-append + (map (lambda (datum) + (sprintf #f " <TH>%s</TH>\\n" (or datum ""))) + columns)))) + +;;@body Outputs a heading row with column-names @1 linked to URIs @2. +(define (html:href-heading columns uris) + (html:heading + (map (lambda (column uri) + (if uri + (html:link uri column) + column)) + columns uris))) + +(define (row->anchor pkl row) + (sprintf #f "<A NAME=\"%s\"></A>" (uri:make-path (butnthcdr pkl row)))) + +;;@args k foreigns +;; +;;The positive integer @1 is the primary-key-limit (number of +;;primary-keys) of the table. @2 is a list of the filenames of +;;foreign-key field pages and #f for non foreign-key fields. +;; +;;@0 returns a procedure taking a row for its single argument. This +;;returned procedure returns the html string for that table row. +(define (html:linked-row-converter pkl foreigns) + (define idxs (do ((idx (length foreigns) (+ -1 idx)) + (nats '() (cons idx nats))) + ((not (positive? idx)) nats))) + (require 'pretty-print) + (lambda (row) + (define (present datum) + (if (or (string? datum) (symbol? datum)) + (html:plain datum) + (let* ((str (pretty-print->string datum)) + (len (+ -1 (string-length str)))) + (cond ((eqv? (string-index str #\newline) len) + (string-append "<TT>" (substring str 0 len) "</TT>")) + (else (html:pre str)))))) + (sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n" + (apply string-append + (map (lambda (idx datum foreign) + (sprintf + #f " <TD>%s%s</TD>\\n" + (if (eqv? 1 idx) (row->anchor pkl row) "") + (cond ((or (not datum) (null? datum)) "") + ((not foreign) (present datum)) + ((equal? "catalog-data.html" foreign) + (html:link (make-uri + (table-name->filename datum) + #f #f) + (present datum))) + (else (html:link (make-uri foreign #f datum) + (present datum)))))) + idxs row foreigns))))) + +;;@body +;;Returns the symbol @1 converted to a filename. +(define (table-name->filename table-name) + (and table-name (string-append + (string-subst (symbol->string table-name) "*" "" ":" "_") + ".html"))) + +(define (table-name->column-table-name db table-name) + ((((db 'open-table) '*catalog-data* #f) 'get 'coltab-name) + table-name)) + +;;@args caption db table-name match-key1 @dots{} +;;Returns HTML string for @2 table @3. Every foreign-key value is +;;linked to the page (of the table) defining that key. +;; +;;The optional @4 @dots{} arguments restrict actions to a subset of +;;the table. @xref{Table Operations, match-key}. +(define (table->linked-html caption db table-name . args) + (let* ((table ((db 'open-table) table-name #f)) + (foreigns (table 'column-foreigns)) + (tags (map table-name->filename foreigns)) + (names (table 'column-names)) + (primlim (table 'primary-limit))) + (apply html:table "CELLSPACING=0 BORDER=1" + (html:caption caption 'BOTTOM) + (html:href-heading + names + (append (make-list primlim + (table-name->filename + (table-name->column-table-name db table-name))) + (make-list (- (length names) primlim) #f))) + (html:heading (table 'column-domains)) + (html:href-heading foreigns tags) + (html:heading (table 'column-types)) + (map (html:linked-row-converter primlim tags) + (apply (table 'row:retrieve*) args))))) + +;;@body +;;Returns a complete HTML page. The string @3 names the page which +;;refers to this one. +;; +;;The optional @4 @dots{} arguments restrict actions to a subset of +;;the table. @xref{Table Operations, match-key}. +(define (table->linked-page db table-name index-filename . args) + (string-append + (if index-filename + (html:head table-name + (html:link (make-uri index-filename #f table-name) + (html:plain table-name))) + (html:head table-name)) + (html:body (apply table->linked-html table-name db table-name args)))) + +(define (html:catalog-row-converter row foreigns) + (sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n" + (apply string-append + (map (lambda (datum foreign) + (sprintf #f " <TD>%s%s</TD>\\n" + (html:anchor (sprintf #f "%s" datum)) + (html:link (make-uri foreign #f #f) datum))) + row foreigns)))) + +;;@body +;;Returns HTML string for the catalog table of @1. +(define (catalog->html db caption . args) + (apply html:table "BORDER=1" + (html:caption caption 'BOTTOM) + (html:heading '(table columns)) + (map (lambda (row) + (cond ((and (eq? '*columns* (caddr row)) + (not (eq? '*columns* (car row)))) + "") + (else (html:catalog-row-converter + (list (car row) (caddr row)) + (list (table-name->filename (car row)) + (table-name->filename (caddr row))))))) + (apply (((db 'open-table) '*catalog-data* #f) 'row:retrieve*) + args)))) + +;;Returns complete HTML page (string) for the catalog table of @1. +(define (catalog->page db caption . args) + (string-append (html:head caption) + (html:body (apply catalog->html db caption args)))) + +;;@subsection HTML editing tables + +;;@noindent A client can modify one row of an editable table at a time. +;;For any change submitted, these routines check if that row has been +;;modified during the time the user has been editing the form. If so, +;;an error page results. +;; +;;@noindent The behavior of edited rows is: +;; +;;@itemize @bullet +;;@item +;;If no fields are changed, then no change is made to the table. +;;@item +;;If the primary keys equal null-keys (parameter defaults), and no other +;;user has modified that row, then that row is deleted. +;;@item +;;If only primary keys are changed, there are non-key fields, and no +;;row with the new keys is in the table, then the old row is +;;deleted and one with the new keys is inserted. +;;@item +;;If only non-key fields are changed, and that row has not been +;;modified by another user, then the row is changed to reflect the +;;fields. +;;@item +;;If both keys and non-key fields are changed, and no row with the +;;new keys is in the table, then a row is created with the new +;;keys and fields. +;;@item +;;If fields are changed, all fields are primary keys, and no row with +;;the new keys is in the table, then a row is created with the new +;;keys. +;;@end itemize +;; +;;@noindent After any change to the table, a @code{sync-database} of the +;;database is performed. + +;;@args table-name null-keys update delete retrieve +;;@args table-name null-keys update delete +;;@args table-name null-keys update +;;@args table-name null-keys +;; +;;Returns procedure (of @var{db}) which returns procedure to modify row +;;of @1. @2 is the list of @dfn{null} keys which indicate that the row +;;is to be deleted. Optional arguments @3, @4, and @5 default to the +;;@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @1 in +;;@var{db}. +(define (command:modify-table table-name null-keys . args) + (define argc (length args)) + (lambda (rdb) + (define table ((rdb 'open-table) table-name #t)) + (let ((table:update (or (and (> argc 0) (car args)) (table 'row:update))) + (table:delete (or (and (> argc 1) (cadr args)) (table 'row:delete))) + (table:retrieve (or (and (> argc 2) (caddr args)) (table 'row:retrieve))) + (pkl (length null-keys))) + (define ptypes (butnthcdr pkl (table 'column-types))) + (if (> argc 4) (slib:error 'command:modify-table 'too-many-args + table-name null-keys args)) + (lambda (*keys* *row-hash* . new-row) + (let* ((new-pkeys (butnthcdr pkl new-row)) + (pkeys (uri:path->keys (uri:split-fields *keys* #\/) ptypes)) + (row (apply table:retrieve pkeys)) + (same-nonkeys? (equal? (nthcdr pkl new-row) (nthcdr pkl row)))) + (cond ((equal? pkeys new-pkeys) ;did not change keys + (cond ((not row) '("Row deleted by other user")) + ((equal? (crc:hash-obj row) *row-hash*) + (table:update new-row) + ((rdb 'sync-database)) #t) + (else '("Row changed by other user")))) + ((equal? null-keys new-pkeys) ;blanked keys + (cond ((not row) #t) + ((equal? (crc:hash-obj row) *row-hash*) + ;;(slib:warn (sprintf #f "Removing key: %#a => %#a" new-pkeys )) + (apply table:delete pkeys) + ((rdb 'sync-database)) #t) + (else '("Row changed by other user")))) + (else ;changed keys + (set! row (apply table:retrieve new-pkeys)) + (cond (row (list "Row already exists" + (sprintf #f "%#a" row))) + (else (table:update new-row) + (if (and same-nonkeys? + (not (null? (nthcdr pkl new-row)))) + (apply table:delete pkeys)) + ((rdb 'sync-database)) #t))))))))) + +;;@body Given @2 in @1, creates parameter and @code{*command*} tables +;;for editing one row of @2 at a time. @0 returns a procedure taking a +;;row argument which returns the HTML string for editing that row. +;; +;;Optional @3 are expressions (lists) added to the call to +;;@code{command:modify-table}. +;; +;;The domain name of a column determines the expected arity of the data +;;stored in that column. Domain names ending in: +;; +;;@table @samp +;;@item * +;;have arity @samp{nary}; +;;@item + +;;have arity @samp{nary1}. +;;@end table +(define (command:make-editable-table rdb table-name . args) + (define table ((rdb 'open-table) table-name #t)) + (let ((pkl (table 'primary-limit)) + (columns (table 'column-names)) + (domains (table 'column-domains)) + (types (table 'column-types)) + (idxs (do ((idx (length (table 'column-names)) (+ -1 idx)) + (nats '() (cons (+ 2 idx) nats))) + ((not (positive? idx)) nats))) + (ftn (((rdb 'open-table) '*domains-data* #f) 'get 'foreign-table))) + (define field-specs + (map (lambda (idx column domain type) + (let* ((dstr (symbol->string domain)) + (len (+ -1 (string-length dstr)))) + (define arity + (case (string-ref dstr len) + ((#\*) 'nary) + ((#\+) 'nary1) + (else 'single))) + (case (string-ref dstr len) + ((#\* #\+) + (set! type (string->symbol (substring dstr 0 len))) + (set! domain type))) + `(,idx ,column ,arity ,domain + ,(make-defaulter arity type) #f ""))) + idxs columns domains types)) + (define foreign-choice-lists + (map (lambda (domain-name) + (define tab-name (ftn domain-name)) + (if tab-name (get-foreign-choices (rdb-open tab-name #f)) '())) + domains)) + (define-tables rdb + `(,(symbol-append table-name '- 'params) + *parameter-columns* *parameter-columns* + ((1 *keys* single string #f #f "") + (2 *row-hash* single string #f #f "") + ,@field-specs)) + `(,(symbol-append table-name '- 'pname) + ((name string)) + ((parameter-index uint)) ;should be address-params + (("*keys*" 1) + ("*row-hash*" 2) + ,@(map (lambda (idx column) (list (symbol->string column) idx)) + idxs columns))) + `(*commands* + desc:*commands* desc:*commands* + ((,(symbol-append 'edit '- table-name) + ,(symbol-append table-name '- 'params) + ,(symbol-append table-name '- 'pname) + (command:modify-table ',table-name + ',(map (lambda (fs) + (caadr (caddar (cddddr fs)))) + (butnthcdr pkl field-specs)) + ,@args) + ,(string-append "Modify " (symbol->string table-name)))))) + (let ((arities (map caddr field-specs))) + (lambda (row) + (define elements + (map form:element + columns + arities + (map (lambda (fld arity) (case arity + ((nary nary1) fld) + (else (list fld)))) + row arities) + foreign-choice-lists)) + (sprintf #f " <TR>\\n <TD>%s</TD>%s\\n </TR>\\n" + (string-append + (html:hidden '*row-hash* (crc:hash-obj row)) + (html:hidden '*keys* (uri:make-path (butnthcdr pkl row))) + ;; (html:hidden '*suggest* '<>) + (car elements) + (form:submit '<> (symbol-append 'edit '- table-name)) + ;; (form:image "Modify Row" "/icons/bang.png") + ) + (apply string-append + (map (lambda (elt) (sprintf #f " <TD>%s</TD>\\n" elt)) + (cdr elements)))))))) + +;;@args k names edit-point edit-converter +;; +;;The positive integer @1 is the primary-key-limit (number of +;;primary-keys) of the table. @2 is a list of the field-names. @3 is +;;the list of primary-keys denoting the row to edit (or #f). @4 is the +;;procedure called with @1, @2, and the row to edit. +;; +;;@0 returns a procedure taking a row for its single argument. This +;;returned procedure returns the html string for that table row. +;; +;;Each HTML table constructed using @0 has first @1 fields (typically +;;the primary key fields) of each row linked to a text encoding of these +;;fields (the result of calling @code{row->anchor}). The page so +;;referenced typically allows the user to edit fields of that row. +(define (html:editable-row-converter pkl names edit-point edit-converter) + (require 'pretty-print) + (let ((idxs (do ((idx (length names) (+ -1 idx)) + (nats '() (cons idx nats))) + ((not (positive? idx)) nats))) + (datum->html + (lambda (datum) + (if (or (string? datum) (symbol? datum)) + (html:plain datum) + (let* ((str (pretty-print->string datum)) + (len (+ -1 (string-length str)))) + (cond ((eqv? (string-index str #\newline) len) + (string-append "<B>" (substring str 0 len) "</B>")) + (else (html:pre str)))))))) + (lambda (row) + (string-append + (sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n" + (apply string-append + (map (lambda (idx datum foreign) + (sprintf + #f " <TD>%s%s</TD>\\n" + (if (eqv? 1 idx) (row->anchor pkl row) "") + (cond ((or (not datum) (null? datum)) "") + ((<= idx pkl) + (let ((keystr (uri:make-path + (butnthcdr pkl row)))) + (sprintf #f "<A HREF=\"%s#%s\">%s</A>" + keystr keystr + (datum->html datum)))) + (else (datum->html datum))))) + idxs row names))) + (if (and edit-point edit-converter + (equal? (butnthcdr pkl edit-point) (butnthcdr pkl row))) + (edit-converter row) + ""))))) + +;;@subsection HTML databases + +;;@body @1 must be a relational database. @2 must be #f or a +;;non-empty string naming an existing sub-directory of the current +;;directory. +;; +;;@0 creates an html page for each table in the database @1 in the +;;sub-directory named @2, or the current directory if @2 is #f. The +;;top level page with the catalog of tables (captioned @4) is written +;;to a file named @3. +(define (db->html-files db dir index-filename caption) + (call-with-output-file (in-vicinity (if dir (sub-vicinity "" dir) "") + index-filename) + (lambda (port) + (display (catalog->page db caption) port))) + ((((db 'open-table) '*catalog-data* #f) 'for-each-row) + (lambda (row) + (call-with-output-file + (in-vicinity (sub-vicinity "" dir) (table-name->filename (car row))) + (lambda (port) + (display (table->linked-page db (car row) index-filename) port)))))) + +;;@args db dir index-filename +;;@args db dir +;;@1 must be a relational database. @2 must be a non-empty +;;string naming an existing sub-directory of the current directory or +;;one to be created. The optional string @3 names the filename of the +;;top page, which defaults to @file{index.html}. +;; +;;@0 creates sub-directory @2 if neccessary, and calls +;;@code{(db->html-files @1 @2 @3 @2)}. The @samp{file:} URI of @3 is +;;returned. +(define (db->html-directory db dir . index-filename) + (set! index-filename (if (null? index-filename) + "index.html" + (car index-filename))) + (if (symbol? dir) (set! dir (symbol->string dir))) + (if (not (file-exists? dir)) (make-directory dir)) + (db->html-files db dir index-filename dir) + (path->uri (in-vicinity (sub-vicinity "" dir) index-filename))) + +;;@args db dir index-filename +;;@args db dir +;;@0 is just like @code{db->html-directory}, but calls +;;@code{browse-url-netscape} with the uri for the top page after the +;;pages are created. +(define (db->netscape . args) + (browse-url-netscape (apply db->html-directory args))) diff --git a/module/slib/db2html.txi b/module/slib/db2html.txi new file mode 100644 index 000000000..0acdd46cf --- /dev/null +++ b/module/slib/db2html.txi @@ -0,0 +1,185 @@ +@code{(require 'db->html)} + + +@defun html:table options row @dots{} + +@end defun + +@defun html:caption caption align + + +@defunx html:caption caption +@var{align} can be @samp{top} or @samp{bottom}. +@end defun + +@defun html:heading columns +Outputs a heading row for the currently-started table. +@end defun + +@defun html:href-heading columns uris +Outputs a heading row with column-names @var{columns} linked to URIs @var{uris}. +@end defun + +@defun html:linked-row-converter k foreigns + + +The positive integer @var{k} is the primary-key-limit (number of +primary-keys) of the table. @var{foreigns} is a list of the filenames of +foreign-key field pages and #f for non foreign-key fields. + +@code{html:linked-row-converter} returns a procedure taking a row for its single argument. This +returned procedure returns the html string for that table row. +@end defun + +@defun table-name->filename table-name + +Returns the symbol @var{table-name} converted to a filename. +@end defun + +@defun table->linked-html caption db table-name match-key1 @dots{} + +Returns HTML string for @var{db} table @var{table-name}. Every foreign-key value is +linked to the page (of the table) defining that key. + +The optional @var{match-key1} @dots{} arguments restrict actions to a subset of +the table. @xref{Table Operations, match-key}. +@end defun + +@defun table->linked-page db table-name index-filename arg @dots{} + +Returns a complete HTML page. The string @var{index-filename} names the page which +refers to this one. + +The optional @var{args} @dots{} arguments restrict actions to a subset of +the table. @xref{Table Operations, match-key}. +@end defun + +@defun catalog->html db caption arg @dots{} + +Returns HTML string for the catalog table of @var{db}. +@end defun +@subsection HTML editing tables + +@noindent A client can modify one row of an editable table at a time. +For any change submitted, these routines check if that row has been +modified during the time the user has been editing the form. If so, +an error page results. + +@noindent The behavior of edited rows is: + +@itemize @bullet +@item +If no fields are changed, then no change is made to the table. +@item +If the primary keys equal null-keys (parameter defaults), and no other +user has modified that row, then that row is deleted. +@item +If only primary keys are changed, there are non-key fields, and no +row with the new keys is in the table, then the old row is +deleted and one with the new keys is inserted. +@item +If only non-key fields are changed, and that row has not been +modified by another user, then the row is changed to reflect the +fields. +@item +If both keys and non-key fields are changed, and no row with the +new keys is in the table, then a row is created with the new +keys and fields. +@item +If fields are changed, all fields are primary keys, and no row with +the new keys is in the table, then a row is created with the new +keys. +@end itemize + +@noindent After any change to the table, a @code{sync-database} of the +database is performed. + + +@defun command:modify-table table-name null-keys update delete retrieve + + +@defunx command:modify-table table-name null-keys update delete + +@defunx command:modify-table table-name null-keys update + +@defunx command:modify-table table-name null-keys + +Returns procedure (of @var{db}) which returns procedure to modify row +of @var{table-name}. @var{null-keys} is the list of @dfn{null} keys which indicate that the row +@cindex null +is to be deleted. Optional arguments @var{update}, @var{delete}, and @var{retrieve} default to the +@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @var{table-name} in +@var{db}. +@end defun + +@defun command:make-editable-table rdb table-name arg @dots{} +Given @var{table-name} in @var{rdb}, creates parameter and @code{*command*} tables +for editing one row of @var{table-name} at a time. @code{command:make-editable-table} returns a procedure taking a +row argument which returns the HTML string for editing that row. + +Optional @var{args} are expressions (lists) added to the call to +@code{command:modify-table}. + +The domain name of a column determines the expected arity of the data +stored in that column. Domain names ending in: + +@table @samp +@item * +have arity @samp{nary}; +@item + +have arity @samp{nary1}. +@end table +@end defun + +@defun html:editable-row-converter k names edit-point edit-converter + + +The positive integer @var{k} is the primary-key-limit (number of +primary-keys) of the table. @var{names} is a list of the field-names. @var{edit-point} is +the list of primary-keys denoting the row to edit (or #f). @var{edit-converter} is the +procedure called with @var{k}, @var{names}, and the row to edit. + +@code{html:editable-row-converter} returns a procedure taking a row for its single argument. This +returned procedure returns the html string for that table row. + +Each HTML table constructed using @code{html:editable-row-converter} has first @var{k} fields (typically +the primary key fields) of each row linked to a text encoding of these +fields (the result of calling @code{row->anchor}). The page so +referenced typically allows the user to edit fields of that row. +@end defun +@subsection HTML databases + + +@defun db->html-files db dir index-filename caption +@var{db} must be a relational database. @var{dir} must be #f or a +non-empty string naming an existing sub-directory of the current +directory. + +@code{db->html-files} creates an html page for each table in the database @var{db} in the +sub-directory named @var{dir}, or the current directory if @var{dir} is #f. The +top level page with the catalog of tables (captioned @var{caption}) is written +to a file named @var{index-filename}. +@end defun + +@defun db->html-directory db dir index-filename + + +@defunx db->html-directory db dir +@var{db} must be a relational database. @var{dir} must be a non-empty +string naming an existing sub-directory of the current directory or +one to be created. The optional string @var{index-filename} names the filename of the +top page, which defaults to @file{index.html}. + +@code{db->html-directory} creates sub-directory @var{dir} if neccessary, and calls +@code{(db->html-files @var{db} @var{dir} @var{index-filename} @var{dir})}. The @samp{file:} URI of @var{index-filename} is +returned. +@end defun + +@defun db->netscape db dir index-filename + + +@defunx db->netscape db dir +@code{db->netscape} is just like @code{db->html-directory}, but calls +@code{browse-url-netscape} with the uri for the top page after the +pages are created. +@end defun diff --git a/module/slib/dbrowse.scm b/module/slib/dbrowse.scm new file mode 100644 index 000000000..082cef3e5 --- /dev/null +++ b/module/slib/dbrowse.scm @@ -0,0 +1,92 @@ +;;; "dbrowse.scm" relational-database-browser +; Copyright 1996, 1997, 1998 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 #f) + (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")) + ((not table-name) + (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:\\n" table-name) + ((table 'for-each-row) + (lambda (row) (printf "\\t%s\\n" (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\\n" 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 "\\n")) + (for-each (lambda (domain) (printf underline)) + (table 'column-domains)) + (newline) + ((table 'for-each-row) + (lambda (row) + (apply printf form row))))) diff --git a/module/slib/dbutil.scm b/module/slib/dbutil.scm new file mode 100644 index 000000000..38ab4ab40 --- /dev/null +++ b/module/slib/dbutil.scm @@ -0,0 +1,313 @@ +;;; "dbutil.scm" relational-database-utilities +; Copyright 1994, 1995, 1997, 2000, 2001 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) +(require 'common-list-functions) + +(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:check-domain 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)))) + (if fkname (let* ((fktab ((rdb 'open-table) fkname #f)) + (p? (fktab 'get 1))) + (if dir (lambda (e) (and (dir e) (p? e))) p?)) + dir))))) + +(define (dbutil:create-database path type) + (require type) + (let ((rdb (((make-relational-system (slib:eval type)) 'create-database) + path))) + (dbutil:define-tables + rdb + '(type + ((name symbol)) + () + ((atom) + (symbol) + (string) + (number) + (money) + (date-time) + (boolean) + (foreign-key) + (expression) + (virtual))) + '(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 1) + (parameter-name-translation *catalog-data* #f symbol 1) + (parameter-arity parameter-arity #f symbol 1) + (table *catalog-data* #f atom 1))) + (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 defaulter #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)) + ()) + '(add-domain-params + *parameter-columns* + *parameter-columns* + ((1 domain-name single atom #f #f "new domain name") + (2 foreign-table optional table #f #f + "if present, domain-name must be existing key into this table") + (3 domain-integrity-rule optional expression #f #f + "returns #t if single argument is good") + (4 type-id single type #f #f "base type of new domain") + (5 type-param optional expression #f #f + "which (key) field of the foreign-table") + )) + '(add-domain-pnames + ((name string)) + ((parameter-index uint)) ;should be add-domain-params + ( + ("n" 1) ("name" 1) + ("f" 2) ("foreign (key) table" 2) + ("r" 3) ("domain integrity rule" 3) + ("t" 4) ("type" 4) + ("p" 5) ("type param" 5) + )) + '(del-domain-params + *parameter-columns* + *parameter-columns* + ((1 domain-name single domain #f #f "domain name"))) + '(del-domain-pnames + ((name string)) + ((parameter-index uint)) ;should be del-domain-params + (("n" 1) ("name" 1))) + '(*commands* + ((name symbol)) + ((parameters parameter-list) + (parameter-names parameter-name-translation) + (procedure expression) + (documentation string)) + ((domain-checker + no-parameters + no-parameter-names + dbutil:check-domain + "return procedure to check given domain name") + + (add-domain + add-domain-params + add-domain-pnames + (lambda (rdb) + (((rdb 'open-table) '*domains-data* #t) 'row:update)) + "add a new domain") + + (delete-domain + del-domain-params + del-domain-pnames + (lambda (rdb) + (((rdb 'open-table) '*domains-data* #t) 'row:remove)) + "delete a domain")))) + (let* ((tab ((rdb 'open-table) '*domains-data* #t)) + (row ((tab 'row:retrieve) 'type))) + (set-car! (cdr row) 'type) + ((tab 'row:update) row)) + (dbutil:wrap-command-interface rdb))) + +(define (make-defaulter arity type) + `(lambda (pl) + ',(case arity + ((optional nary) '()) + ((boolean) #f) + ((single nary1) + (case type + ((string) '("")) + ((symbol) '(nil)) + (else '(#f)))) + (else (slib:error 'make-defaulter 'unknown 'arity arity))))) + +(define (get-foreign-choices tab) + (define dlst ((tab 'get* 1))) + (do ((dlst dlst (cdr dlst)) + (vlst (if (memq 'visible-name (tab 'column-names)) + ((tab 'get* 'visible-name)) + dlst) + (cdr vlst)) + (out '() (if (member (car dlst) (cdr dlst)) + out + (cons (list (car dlst) (car vlst)) out)))) + ((null? dlst) out))) + +(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) + (cond ((not comname) (set! comname '*default*))) + (cond ((not (comgetrow comname)) + (slib:error 'command 'not 'known: comname))) + (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))) + (defaulters (map slib:eval ((parameter-table 'get* 'defaulter)))) + (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 defaulters 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)) 1)))))) + (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 (dbutil:list-table-definition rdb table-name) + (cond (((rdb 'table-exists?) table-name) + (let* ((table ((rdb 'open-table) table-name #f)) + (prilimit (table 'primary-limit)) + (coldefs (map list + (table 'column-names) + (table 'column-domains)))) + (list table-name + (butnthcdr prilimit coldefs) + (nthcdr prilimit coldefs) + ((table 'row:retrieve*))))) + (else #f))) + +(define create-database dbutil:create-database) +(define open-database! dbutil:open-database!) +(define open-database dbutil:open-database) +(define define-tables dbutil:define-tables) +(define list-table-definition dbutil:list-table-definition) diff --git a/module/slib/debug.scm b/module/slib/debug.scm new file mode 100644 index 000000000..4b50d9d53 --- /dev/null +++ b/module/slib/debug.scm @@ -0,0 +1,98 @@ +;;;; "debug.scm" Utility functions for debugging in Scheme. +;;; Copyright (C) 1991, 1992, 1993, 1995, 1999 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) +(require 'line-i/o) + +(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) (proc exp)) + ((define) (proc exp)))))))) + (if (eqv? #\# (peek-char port)) + (read-line port)) ;remove `magic-number' + (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) + (and (eqv? 'define (car form)) + (let ((sym (get-defined-symbol (cadr form)))) + (cond ((procedure? (slib:eval sym)) + (proc sym))))))))) + +(define (trace-all file . ...) + (for-each + (lambda (file) + (for-each-top-level-defined-procedure-symbol-in-file + file + (lambda (sym) + (slib:eval `(set! ,sym (trace:trace-procedure 'trace ,sym ',sym)))))) + (cons file ...))) +(define (track-all file . ...) + (for-each + (lambda (file) + (for-each-top-level-defined-procedure-symbol-in-file + file + (lambda (sym) + (slib:eval `(set! ,sym (trace:trace-procedure 'track ,sym ',sym)))))) + (cons file ...))) +(define (stack-all file . ...) + (for-each + (lambda (file) + (for-each-top-level-defined-procedure-symbol-in-file + file + (lambda (sym) + (slib:eval `(set! ,sym (trace:trace-procedure 'stack ,sym ',sym)))))) + (cons file ...))) + +(define (break-all file . ...) + (for-each + (lambda (file) + (for-each-top-level-defined-procedure-symbol-in-file + file + (lambda (sym) + (slib:eval `(set! ,sym (break:breakf ,sym ',sym)))))) + (cons file ...))) diff --git a/module/slib/defmacex.scm b/module/slib/defmacex.scm new file mode 100644 index 000000000..4c6d8bd91 --- /dev/null +++ b/module/slib/defmacex.scm @@ -0,0 +1,100 @@ +;;;"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)))) + ((defmacro) + (cons (car e) + (cons (cadr e) + (cons (caddr e) (map defmacro:expand* (cdddr e)))))) + (else (map defmacro:expand* e))))) + e)) diff --git a/module/slib/determ.scm b/module/slib/determ.scm new file mode 100644 index 000000000..4b53e5f06 --- /dev/null +++ b/module/slib/determ.scm @@ -0,0 +1,14 @@ +;"determ.scm" Determinant + +(define (determinant m) + (define (butnth n lst) + (if (zero? n) (cdr lst) (cons (car lst) (butnth (+ -1 n) (cdr lst))))) + (define (minor m i j) + (map (lambda (x) (butnth j x)) (butnth i m))) + (define (cofactor m i j) + (* (if (odd? (+ i j)) -1 1) (determinant (minor m i j)))) + (define n (length m)) + (if (eqv? 1 n) (caar m) + (do ((j (+ -1 n) (+ -1 j)) + (ans 0 (+ ans (* (list-ref (car m) j) (cofactor m 0 j))))) + ((negative? j) ans)))) diff --git a/module/slib/dwindtst.scm b/module/slib/dwindtst.scm new file mode 100644 index 000000000..8d6480029 --- /dev/null +++ b/module/slib/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/module/slib/dynamic.scm b/module/slib/dynamic.scm new file mode 100644 index 000000000..937f93e0e --- /dev/null +++ b/module/slib/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/module/slib/dynwind.scm b/module/slib/dynwind.scm new file mode 100644 index 000000000..921242263 --- /dev/null +++ b/module/slib/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/module/slib/elk.init b/module/slib/elk.init new file mode 100644 index 000000000..022121c51 --- /dev/null +++ b/module/slib/elk.init @@ -0,0 +1,303 @@ +;;;"elk.init" Initialisation file for SLIB for ELK 2.1 -*- Scheme -*- +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. + +; 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-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) + "http://www.informatik.uni-bremen.de/~net/elk/") + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "3.0") + +;;; (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. + +(require 'unix) +(define getenv unix-getenv) +(define system unix-system) + +(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))) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define home-vicinity + (let ((home-path (getenv "HOME"))) + (lambda () home-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))))) + +; 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) + +;;; 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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;;; define an error procedure for the library +(define slib:error + (lambda args +(define (slib:error . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (apply s48-error args)) + (let ((port (open-output-string)) + (err (if (and (pair? args) (symbol? (car args))) + (car args) 'slib)) + (args (if (and (pair? args) (symbol? (car args))) + (cdr args) args))) + (for-each (lambda (x) (display x port) (display " " port)) args) + (let ((str (get-output-string port))) + (close-output-port port) + (error err str))))) + +;;; 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/module/slib/eval.scm b/module/slib/eval.scm new file mode 100644 index 000000000..cc4b8168c --- /dev/null +++ b/module/slib/eval.scm @@ -0,0 +1,146 @@ +; "eval.scm", Eval proposed by Guillermo (Bill) J. Rozas for R5RS. +; Copyright (c) 1997, 1998 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. + +;;; Rather than worry over the status of all the optional procedures, +;;; just require as many as possible. + +(require 'rev4-optional-procedures) +(require 'dynamic-wind) +(require 'transcript) +(require 'with-file) +(require 'values) + +(define eval:make-environment + (let ((eval-1 slib:eval)) + (lambda (identifiers) + ((lambda args args) + #f + identifiers + (lambda (expression) + (eval-1 `(lambda ,identifiers ,expression))))))) + +(define eval:capture-environment! + (let ((set-car! set-car!) + (eval-1 slib:eval) + (apply apply)) + (lambda (environment) + (set-car! + environment + (apply (lambda (environment-values identifiers procedure) + (eval-1 `((lambda args args) ,@identifiers))) + environment))))) + +(define interaction-environment + (let ((env (eval:make-environment '()))) + (lambda () env))) + +;;; null-environment is set by first call to scheme-report-environment at +;;; the end of this file. +(define null-environment #f) + +(define scheme-report-environment + (let* ((r4rs-procedures + (append + (cond ((provided? 'inexact) + (append + '(acos angle asin atan cos exact->inexact exp + expt imag-part inexact->exact log magnitude + make-polar make-rectangular real-part sin + sqrt tan) + (if (let ((n (string->number "1/3"))) + (and (number? n) (exact? n))) + '(denominator numerator) + '()))) + (else '())) + (cond ((provided? 'rationalize) + '(rationalize)) + (else '())) + (cond ((provided? 'delay) + '(force)) + (else '())) + (cond ((provided? 'char-ready?) + '(char-ready?)) + (else '())) + '(* + - / < <= = > >= abs append apply assoc assq assv boolean? + caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar + caddar cadddr caddr cadr call-with-current-continuation + call-with-input-file call-with-output-file car cdaaar cdaadr + cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr + cdddr cddr cdr ceiling char->integer char-alphabetic? char-ci<=? + char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase + char-lower-case? char-numeric? char-upcase char-upper-case? + char-whitespace? char<=? char<? char=? char>=? char>? char? + close-input-port close-output-port complex? cons + current-input-port current-output-port display eof-object? eq? + equal? eqv? even? exact? floor for-each gcd inexact? + input-port? integer->char integer? lcm length list list->string + list->vector list-ref list-tail list? load make-string + make-vector map max member memq memv min modulo negative? + newline not null? number->string number? odd? open-input-file + open-output-file output-port? pair? peek-char positive? + procedure? quotient rational? read read-char real? remainder + reverse round set-car! set-cdr! string string->list + string->number string->symbol string-append string-ci<=? + string-ci<? string-ci=? string-ci>=? string-ci>? string-copy + string-fill! string-length string-ref string-set! string<=? + string<? string=? string>=? string>? string? substring + symbol->string symbol? transcript-off transcript-on truncate + vector vector->list vector-fill! vector-length vector-ref + vector-set! vector? with-input-from-file with-output-to-file + write write-char zero? + ))) + (r5rs-procedures + (append + '(call-with-values dynamic-wind eval interaction-environment + null-environment scheme-report-environment values) + r4rs-procedures)) + (r4rs-environment (eval:make-environment r4rs-procedures)) + (r5rs-environment (eval:make-environment r4rs-procedures))) + (let ((car car)) + (lambda (version) + (cond ((car r5rs-environment)) + (else + (let ((null-env (eval:make-environment r5rs-procedures))) + (set-car! null-env (map (lambda (i) #f) r5rs-procedures)) + (set! null-environment (lambda version null-env))) + (eval:capture-environment! r4rs-environment) + (eval:capture-environment! r5rs-environment))) + (case version + ((4) r4rs-environment) + ((5) r5rs-environment) + (else (slib:error 'eval 'version version 'not 'available))))))) + +(define eval + (let ((eval-1 slib:eval) + (apply apply) + (null? null?) + (eq? eq?)) + (lambda (expression . environment) + (if (null? environment) (eval-1 expression) + (apply + (lambda (environment) + (if (eq? (interaction-environment) environment) (eval-1 expression) + (apply (lambda (environment-values identifiers procedure) + (apply (procedure expression) environment-values)) + environment))) + environment))))) +(set! slib:eval eval) + +;;; Now that all the R5RS procedures are defined, capture r5rs-environment. +(and (scheme-report-environment 5) #t) diff --git a/module/slib/factor.scm b/module/slib/factor.scm new file mode 100644 index 000000000..f10f0d589 --- /dev/null +++ b/module/slib/factor.scm @@ -0,0 +1,245 @@ +;;;; "factor.scm" factorization, prime test and generation +;;; Copyright (C) 1991, 1992, 1993, 1998 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 'common-list-functions) +(require 'modular) +(require 'random) +(require 'byte) + +;;@body +;;@0 is the random-state (@pxref{Random Numbers}) used by these +;;procedures. If you call these procedures from more than one thread +;;(or from interrupt), @code{random} may complain about reentrant +;;calls. +(define prime:prngs + (make-random-state "repeatable seed for primes")) + + +;;@emph{Note:} The prime test and generation procedures implement (or +;;use) the Solovay-Strassen primality test. See +;; +;;@itemize @bullet +;;@item Robert Solovay and Volker Strassen, +;;@cite{A Fast Monte-Carlo Test for Primality}, +;;SIAM Journal on Computing, 1977, pp 84-85. +;;@end itemize + +;;; Solovay-Strassen Prime Test +;;; if n is prime, then J(a,n) is congruent mod n to a**((n-1)/2) + +;;; (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)))))) +;;@args p q +;;Returns the value (+1, @minus{}1, or 0) of the Jacobi-Symbol of +;;exact non-negative integer @1 and exact positive odd integer @2. +(define jacobi-symbol prime:jacobi-symbol) + +;;@body +;;@0 the maxinum number of iterations of Solovay-Strassen that will +;;be done to test a number for primality. +(define prime:trials 30) + +;;; 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 (Solovay-Strassen-prime? n) + (do ((i prime:trials (- i 1)) + (a (+ 2 (random (- n 2) prime:prngs)) + (+ 2 (random (- n 2) prime:prngs)))) + ((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)))) + +;;; prime:products are products of small primes. +(define (primes-gcd? n comps) + (comlist:notevery (lambda (prd) (= 1 (gcd n prd))) comps)) +(define prime:prime-sqr 121) +(define prime:products '(105)) +(define prime:sieve (bytes 0 0 1 1 0 1 0 1 0 0 0)) +(letrec ((lp (lambda (comp comps primes nexp) + (cond ((< comp (quotient most-positive-fixnum nexp)) + (let ((ncomp (* nexp comp))) + (lp ncomp comps + (cons nexp primes) + (next-prime nexp (cons ncomp comps))))) + ((< (quotient comp nexp) (* nexp nexp)) + (set! prime:prime-sqr (* nexp nexp)) + (set! prime:sieve (make-bytes nexp 0)) + (for-each (lambda (prime) + (byte-set! prime:sieve prime 1)) + primes) + (set! prime:products (reverse (cons comp comps)))) + (else + (lp nexp (cons comp comps) + (cons nexp primes) + (next-prime nexp (cons comp comps))))))) + (next-prime (lambda (nexp comps) + (set! comps (reverse comps)) + (do ((nexp (+ 2 nexp) (+ 2 nexp))) + ((not (primes-gcd? nexp comps)) nexp))))) + (lp 3 '() '(2 3) 5)) + +(define (prime:prime? n) + (set! n (abs n)) + (cond ((< n (bytes-length prime:sieve)) (positive? (byte-ref prime:sieve n))) + ((even? n) #f) + ((primes-gcd? n prime:products) #f) + ((< n prime:prime-sqr) #t) + (else (Solovay-Strassen-prime? n)))) +;;@args n +;;Returns @code{#f} if @1 is composite; @code{#t} if @1 is prime. +;;There is a slight chance @code{(expt 2 (- prime:trials))} that a +;;composite will return @code{#t}. +(define prime? prime:prime?) +(define probably-prime? prime:prime?) ;legacy + +(define (prime:prime< start) + (do ((nbr (+ -1 start) (+ -1 nbr))) + ((or (negative? nbr) (prime:prime? nbr)) + (if (negative? nbr) #f nbr)))) + +(define (prime:primes< start count) + (do ((cnt (+ -2 count) (+ -1 cnt)) + (lst '() (cons prime lst)) + (prime (prime:prime< start) (prime:prime< prime))) + ((or (not prime) (negative? cnt)) + (if prime (cons prime lst) lst)))) +;;@args start count +;;Returns a list of the first @2 prime numbers less than +;;@1. If there are fewer than @var{count} prime numbers +;;less than @var{start}, then the returned list will have fewer than +;;@var{start} elements. +(define primes< prime:primes<) + +(define (prime:prime> start) + (do ((nbr (+ 1 start) (+ 1 nbr))) + ((prime:prime? nbr) nbr))) + +(define (prime:primes> start count) + (set! start (max 0 start)) + (do ((cnt (+ -2 count) (+ -1 cnt)) + (lst '() (cons prime lst)) + (prime (prime:prime> start) (prime:prime> prime))) + ((negative? cnt) + (reverse (cons prime lst))))) +;;@args start count +;;Returns a list of the first @2 prime numbers greater than @1. +(define primes> prime:primes>) + +;;;;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:fo m) + (let* ((s (gcd m (car prime:products))) + (r (quotient m s))) + (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 (prime:fe m) + (if (even? m) + (cons 2 (prime:fe (quotient m 2))) + (if (eqv? 1 m) + '() + (prime:fo m)))) + +(define (prime:factor k) + (case k + ((-1 0 1) (list k)) + (else (if (negative? k) + (cons -1 (prime:fe (- k))) + (prime:fe k))))) +;;@args k +;;Returns a list of the prime factors of @1. The order of the +;;factors is unspecified. In order to obtain a sorted list do +;;@code{(sort! (factor @var{k}) <)}. +(define factor prime:factor) diff --git a/module/slib/factor.txi b/module/slib/factor.txi new file mode 100644 index 000000000..38c0dd1a3 --- /dev/null +++ b/module/slib/factor.txi @@ -0,0 +1,56 @@ + +@defvar prime:prngs + +@var{prime:prngs} is the random-state (@pxref{Random Numbers}) used by these +procedures. If you call these procedures from more than one thread +(or from interrupt), @code{random} may complain about reentrant +calls. +@end defvar +@emph{Note:} The prime test and generation procedures implement (or +use) the Solovay-Strassen primality test. See + +@itemize @bullet +@item Robert Solovay and Volker Strassen, +@cite{A Fast Monte-Carlo Test for Primality}, +SIAM Journal on Computing, 1977, pp 84-85. +@end itemize + + +@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}. +@end defun + +@defvar prime:trials + +@var{prime:trials} the maxinum number of iterations of Solovay-Strassen that will +be done to test a number for primality. +@end defvar + +@defun prime? n + +Returns @code{#f} if @var{n} is composite; @code{#t} if @var{n} is prime. +There is a slight chance @code{(expt 2 (- prime:trials))} that a +composite will return @code{#t}. +@end defun + +@defun primes< start count + +Returns a list of the first @var{count} prime numbers less than +@var{start}. If there are fewer than @var{count} prime numbers +less than @var{start}, then the returned list will have fewer than +@var{start} elements. +@end defun + +@defun primes> start count + +Returns a list of the first @var{count} prime numbers greater than @var{start}. +@end defun + +@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 @var{k}) <)}. +@end defun diff --git a/module/slib/fft.scm b/module/slib/fft.scm new file mode 100644 index 000000000..0936c1cfc --- /dev/null +++ b/module/slib/fft.scm @@ -0,0 +1,70 @@ +;;;"fft.scm" Fast Fourier Transform +;Copyright (C) 1999 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. + +;;;; See: +;;; Introduction to Algorithms (MIT Electrical +;;; Engineering and Computer Science Series) +;;; by Thomas H. Cormen, Charles E. Leiserson (Contributor), +;;; Ronald L. Rivest (Contributor) +;;; MIT Press; ISBN: 0-262-03141-8 (July 1990) + +;;; http://www.astro.virginia.edu/~eww6n/math/DiscreteFourierTransform.html +;;; differs in the direction of rotation of the complex unit vectors. + +(require 'array) + +(define (fft:shuffled&scaled ara n scale) + (define lgn (integer-length (+ -1 n))) + (define new (apply make-array 0 (array-dimensions ara))) + (define bit-reverse (lambda (width in) + (if (zero? width) 0 + (+ (bit-reverse (+ -1 width) (quotient in 2)) + (ash (modulo in 2) (+ -1 width)))))) + (if (not (eqv? n (expt 2 lgn))) + (slib:error 'fft "array length not power of 2" n)) + (do ((k 0 (+ 1 k))) + ((>= k n) new) + (array-set! new (* (array-ref ara k) scale) (bit-reverse lgn k)))) + +(define (dft! ara n dir) + (define lgn (integer-length (+ -1 n))) + (define pi2i (* 0+8i (atan 1))) + (do ((s 1 (+ 1 s))) + ((> s lgn) ara) + (let* ((m (expt 2 s)) + (w_m (exp (* dir (/ pi2i m)))) + (m/2-1 (+ (quotient m 2) -1))) + (do ((j 0 (+ 1 j)) + (w 1 (* w w_m))) + ((> j m/2-1)) + (do ((k j (+ m k))) + ((>= k n)) + (let* ((k+m/2 (+ k m/2-1 1)) + (t (* w (array-ref ara k+m/2))) + (u (array-ref ara k))) + (array-set! ara (+ u t) k) + (array-set! ara (- u t) k+m/2))))))) + +(define (fft ara) + (define n (car (array-dimensions ara))) + (dft! (fft:shuffled&scaled ara n 1) n 1)) + +(define (fft-1 ara) + (define n (car (array-dimensions ara))) + (dft! (fft:shuffled&scaled ara n (/ n)) n -1)) diff --git a/module/slib/fluidlet.scm b/module/slib/fluidlet.scm new file mode 100644 index 000000000..59ba481cb --- /dev/null +++ b/module/slib/fluidlet.scm @@ -0,0 +1,40 @@ +; "fluidlet.scm", FLUID-LET for Scheme +; Copyright (c) 1998, 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) +(require 'common-list-functions) ;MAKE-LIST + +(defmacro fluid-let (clauses . body) + (let ((ids (map car clauses)) + (new-tmps (map (lambda (x) (gentemp)) clauses)) + (old-tmps (map (lambda (x) (gentemp)) clauses))) + `(let (,@(map list new-tmps (map cadr clauses)) + ,@(map list old-tmps (make-list (length clauses) #f))) + (dynamic-wind + (lambda () + ,@(map (lambda (ot id) `(set! ,ot ,id)) + old-tmps ids) + ,@(map (lambda (id nt) `(set! ,id ,nt)) + ids new-tmps)) + (lambda () ,@body) + (lambda () + ,@(map (lambda (nt id) `(set! ,nt ,id)) + new-tmps ids) + ,@(map (lambda (id ot) `(set! ,id ,ot)) + ids old-tmps)))))) diff --git a/module/slib/fmtdoc.txi b/module/slib/fmtdoc.txi new file mode 100644 index 000000000..3e2adb7cc --- /dev/null +++ b/module/slib/fmtdoc.txi @@ -0,0 +1,434 @@ + +@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 ``old fashioned'' 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}@var{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 diff --git a/module/slib/format.scm b/module/slib/format.scm new file mode 100644 index 000000000..d9f1c86a4 --- /dev/null +++ b/module/slib/format.scm @@ -0,0 +1,1675 @@ +;;; "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)) + (format: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")) + + ;; If the first argument is a string, then that's the format string. + ;; (Scheme->C) + ;; In this case, put the argument list in canonical form. + (let ((args (if (string? (car args)) + (cons #f args) + args))) + ;; Use this canonicalized version when reporting errors. + (set! format:args args) + + (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))))) + (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-fill (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) format: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 (memq modifier '(at colon-at)) + (format:error "double `@' modifier")) + (set! modifier (if (eq? modifier 'colon) 'colon-at 'at)) + (tilde-dispatch)) + ((#\:) ; `:' modifier + (if (memq modifier '(colon colon-at)) + (format:error "double `:' modifier")) + (set! modifier (if (eq? modifier 'at) 'colon-at '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 + +(define (format: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 (format:list-head l k) + (if (= k 0) + '() + (cons (car l) (format: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/module/slib/formatst.scm b/module/slib/formatst.scm new file mode 100644 index 000000000..3f1913098 --- /dev/null +++ b/module/slib/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" ,slib: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/module/slib/gambit.init b/module/slib/gambit.init new file mode 100644 index 000000000..6d4976fc5 --- /dev/null +++ b/module/slib/gambit.init @@ -0,0 +1,301 @@ +;;;"gambit.init" Initialization for SLIB for Gambit -*-scheme-*- +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. + +;;; 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 +;;; Hacked yet again for Gambit v2.4, Jan 1997, by Mike Pope + +(define (software-type) 'MACOS) ; for MacGambit. +(define (software-type) 'UNIX) ; for Unix platforms. + +(define (scheme-implementation-type) 'gambit) + +;;; (scheme-implementation-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) + "http://www.iro.umontreal.ca/~gambit/index.html") + +(define (scheme-implementation-version) "3.0") +;;; Jefferson R. Lowrey reports that in Gambit Version 3.0 +;;; (argv) returns '(""). +(define argv + (if (equal? '("") (argv)) ;Fix only if it is broken. + (lambda () '("Lowrey HD:Development:MacGambit 3.0:Interpreter")) + argv)) + +;;; (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) (lambda () "/usr/local/src/scheme/")) + ((VMS) (lambda () "scheme$src:")) + ((MS-DOS) (lambda () "C:\\scheme\\")) + ((WINDOWS) (lambda () "c:/scheme/")) + ((MACOS) + (let ((arg0 (list-ref (argv) 0))) + (let loop ((i (- (string-length arg0) 1))) + (cond ((negative? i) "") + ((char=? #\: (string-ref arg0 i)) + (set! arg0 (substring arg0 0 (+ i 1))) + (lambda () arg0)) + (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:") + ((WINDOWS MS-DOS) "C:\\SLIB\\") + (else "")))) + (lambda () library-path))) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define (home-vicinity) #f) + +;;; *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 +; 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))))) + +;;; Gambit supports SYSTEM as an "Unstable Addition"; Watch for changes. +(define system ##shell-command) + +;;; (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 flush-output) + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-*PUT-FILE. + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; 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) + +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. +(define slib:eval eval) + +; Define program-arguments as argv +(define program-arguments argv) + +;;; If your implementation provides R4RS macros: +;(define macro:eval slib:eval) +;(define macro:load load) + +; Set up defmacro in terms of gambit's define-macro +(define-macro (defmacro name args . body) + `(define-macro (,name ,@args) ,@body)) + +(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 base:eval) + +(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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;; define an error procedure for the library +(define (slib:error . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (apply error args)) + +;; 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 (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) + +;;; (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/module/slib/genwrite.scm b/module/slib/genwrite.scm new file mode 100644 index 000000000..2e4bf6060 --- /dev/null +++ b/module/slib/genwrite.scm @@ -0,0 +1,266 @@ +;;"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 genwrite:newline-str (make-string 1 #\newline)) + +(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 genwrite:newline-str 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 genwrite:newline-str (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/module/slib/getopt.scm b/module/slib/getopt.scm new file mode 100644 index 000000000..c2962dbbe --- /dev/null +++ b/module/slib/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/module/slib/getparam.scm b/module/slib/getparam.scm new file mode 100644 index 000000000..d5bfe1f39 --- /dev/null +++ b/module/slib/getparam.scm @@ -0,0 +1,213 @@ +;;; "getparam.scm" convert getopt to passing parameters by name. +; Copyright 1995, 1996, 1997, 2001 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 'getopt) +(require 'coerce) + +(define (getopt->parameter-list argc argv optnames arities types aliases + . description) + (define (can-take-arg? opt) + (not (eq? 'boolean (list-ref arities (position opt optnames))))) + (let ((progname (list-ref argv (+ -1 *optind*))) + (optlist '()) + (long-opt-list '()) + (optstring #f) + (pos-args '()) + (parameter-list (make-parameter-list optnames)) + (curopt '*unclaimed-argument*) + (positional? (assv 0 aliases)) + (unclaimeds '())) + (define (adjoin-val val curopt) + (define ntyp (list-ref types (position curopt optnames))) + (adjoin-parameters! parameter-list + (list curopt (case ntyp + ((expression) val) + (else (coerce val ntyp)))))) + (define (finish) + (cond + (positional? + (set! unclaimeds (reverse unclaimeds)) + (do ((idx 2 (+ 1 idx)) + (alias+ (assv 1 aliases) (assv idx aliases)) + (alias- (assv -1 aliases) (assv (- idx) aliases))) + ((or (not (or alias+ alias-)) (null? unclaimeds))) + (set! unclaimeds (reverse unclaimeds)) + (cond (alias- + (set! curopt (cadr alias-)) + (adjoin-val (car unclaimeds) curopt) + (set! unclaimeds (cdr unclaimeds)))) + (set! unclaimeds (reverse unclaimeds)) + (cond ((and alias+ (not (null? unclaimeds))) + (set! curopt (cadr alias+)) + (adjoin-val (car unclaimeds) curopt) + (set! unclaimeds (cdr unclaimeds))))) + (let ((alias (assv '0 aliases))) + (cond (alias + (set! curopt (cadr alias)) + (for-each (lambda (unc) (adjoin-val unc curopt)) unclaimeds) + (set! unclaimeds '())))))) + (cond ((not (null? unclaimeds)) + (slib:warn 'getopt->parameter-list 'arguments 'unclaimed unclaimeds) + (apply parameter-list->getopt-usage + progname optnames arities types aliases description)) + (else parameter-list))) + (set! aliases + (map (lambda (alias) + (cond ((string? (car alias)) + (let ((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 #\-)))))) + ((number? (car alias)) + (set! positional? (car alias)) + alias) + (else alias))) + aliases)) + (for-each + (lambda (alias) + (define opt (car alias)) + (cond ((number? opt) (set! pos-args (cons opt pos-args))) + ((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:warn 'getopt->parameter-list + (case opt + ((#\:) "argument missing after") + ((#\?) "unrecognized option")) + (string #\- getopt:opt)) + (apply parameter-list->getopt-usage + progname optnames arities types aliases description)) + ((#f) + (cond ((and (< *optind* argc) + (string=? "-" (list-ref argv *optind*))) + (set! *optind* (+ 1 *optind*)) + (finish)) + ((< *optind* argc) + (let ((topt (assoc curopt aliases))) + (if topt (set! curopt (cadr topt))) + (cond + ((and positional? (not topt)) + (set! unclaimeds + (cons (list-ref argv *optind*) unclaimeds)) + (set! *optind* (+ 1 *optind*)) (loop)) + ((and (member curopt optnames) + (adjoin-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 (finish)))) + (else + (cond ((char? opt) (set! opt (string opt)))) + (let ((topt (assoc opt aliases))) + (if topt (set! topt (cadr topt))) + (cond + ((not topt) + (slib:warn "Option not recognized -" opt) + (apply parameter-list->getopt-usage + progname optnames arities types aliases description)) + ((not (can-take-arg? topt)) + (adjoin-parameters! parameter-list (list topt #t)) + (loop)) + (*optarg* (set! curopt topt) (adjoin-val *optarg* curopt) (loop)) + (else +;;; (slib:warn 'getopt->parameter-list "= missing for option--" opt) + (set! curopt topt) (loop)))))))))) + +(define (parameter-list->getopt-usage comname optnames arities types aliases + . description) + (require 'printf) + (require 'common-list-functions) + (let ((aliast (map list optnames)) + (strlen=1? (lambda (s) (= 1 (string-length s)))) + (cep (current-error-port))) + (for-each (lambda (alias) + (let ((apr (assq (cadr alias) aliast))) + (set-cdr! apr (cons (car alias) (cdr apr))))) + aliases) + (fprintf cep "Usage: %s [OPTION ARGUMENT ...] ..." comname) + (do ((pos+ '()) (pos- '()) + (idx 2 (+ 1 idx)) + (alias+ (assv 1 aliases) (assv idx aliases)) + (alias- (assv -1 aliases) (assv (- idx) aliases))) + ((not (or alias+ alias-)) + (for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias))) + (reverse pos+)) + (let ((alias (assv 0 aliases))) + (if alias (fprintf cep " <%s> ..." (cadr alias)))) + (for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias))) + pos-)) + (cond (alias- (set! pos- (cons alias- pos-)))) + (cond (alias+ (set! pos+ (cons alias+ pos+))))) + (fprintf cep "\\n\\n") + (for-each + (lambda (optname arity aliat) + (let loop ((initials (remove-if-not strlen=1? (remove-if number? (cdr aliat)))) + (longname (remove-if strlen=1? (remove-if number? (cdr aliat))))) + (cond ((and (null? initials) (null? longname))) + (else (fprintf cep + (case arity + ((boolean) " %3s %s\\n") + (else " %3s %s<%s> %s\\n")) + (if (null? initials) + "" + (string-append "-" (car initials) + (if (null? longname) " " ","))) + (if (null? longname) + " " + (string-append "--" (car longname) + (case arity + ((boolean) " ") + (else "=")))) + (case arity + ((boolean) "") + (else optname)) + (case arity + ((nary nary1) "...") + (else ""))) + (loop (if (null? initials) '() (cdr initials)) + (if (null? longname) '() (cdr longname))))))) + optnames arities aliast) + (for-each (lambda (desc) (fprintf cep " %s\\n" desc)) description)) + #f) + +(define (getopt->arglist argc argv optnames positions + arities types defaulters checks aliases . description) + (define progname (list-ref argv (+ -1 *optind*))) + (let* ((params (apply getopt->parameter-list + argc argv optnames arities types aliases description)) + (fparams (and params (fill-empty-parameters defaulters params)))) + (cond ((and (list? params) + (check-parameters checks fparams) + (parameter-list->arglist positions arities fparams))) + (params (apply parameter-list->getopt-usage + progname optnames arities types aliases description)) + (else #f)))) + diff --git a/module/slib/glob.scm b/module/slib/glob.scm new file mode 100644 index 000000000..dc396cd54 --- /dev/null +++ b/module/slib/glob.scm @@ -0,0 +1,227 @@ +;;; "glob.scm" String matching for filenames (a la BASH). +;;; Copyright (C) 1998 Radey Shouman. +; +;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. + +;;$Header: /home/ludo/src/guile/gitification/guile-cvs/guile/guile/guile-vm/module/slib/glob.scm,v 1.1 2001/04/14 11:24:45 kei Exp $ +;;$Name: $ + +(define (glob:pattern->tokens pat) + (cond + ((string? pat) + (let loop ((i 0) + (toks '())) + (if (>= i (string-length pat)) + (reverse toks) + (let ((pch (string-ref pat i))) + (case pch + ((#\? #\*) + (loop (+ i 1) + (cons (substring pat i (+ i 1)) toks))) + ((#\[) + (let ((j + (let search ((j (+ i 2))) + (cond + ((>= j (string-length pat)) + (slib:error 'glob:make-matcher + "unmatched [" pat)) + ((char=? #\] (string-ref pat j)) + (if (and (< (+ j 1) (string-length pat)) + (char=? #\] (string-ref pat (+ j 1)))) + (+ j 1) + j)) + (else (search (+ j 1))))))) + (loop (+ j 1) (cons (substring pat i (+ j 1)) toks)))) + (else + (let search ((j (+ i 1))) + (cond ((= j (string-length pat)) + (loop j (cons (substring pat i j) toks))) + ((memv (string-ref pat j) '(#\? #\* #\[)) + (loop j (cons (substring pat i j) toks))) + (else (search (+ j 1))))))))))) + ((pair? pat) + (for-each (lambda (elt) (or (string? elt) + (slib:error 'glob:pattern->tokens + "bad pattern" pat))) + pat) + pat) + (else (slib:error 'glob:pattern->tokens "bad pattern" pat)))) + +(define (glob:make-matcher pat ch=? ch<=?) + (define (match-end str k kmatch) + (and (= k (string-length str)) (reverse (cons k kmatch)))) + (define (match-str pstr nxt) + (let ((plen (string-length pstr))) + (lambda (str k kmatch) + (and (<= (+ k plen) (string-length str)) + (let loop ((i 0)) + (cond ((= i plen) + (nxt str (+ k plen) (cons k kmatch))) + ((ch=? (string-ref pstr i) + (string-ref str (+ k i))) + (loop (+ i 1))) + (else #f))))))) + (define (match-? nxt) + (lambda (str k kmatch) + (and (< k (string-length str)) + (nxt str (+ k 1) (cons k kmatch))))) + (define (match-set1 chrs) + (let recur ((i 0)) + (cond ((= i (string-length chrs)) + (lambda (ch) #f)) + ((and (< (+ i 2) (string-length chrs)) + (char=? #\- (string-ref chrs (+ i 1)))) + (let ((nxt (recur (+ i 3)))) + (lambda (ch) + (or (and (ch<=? ch (string-ref chrs (+ i 2))) + (ch<=? (string-ref chrs i) ch)) + (nxt ch))))) + (else + (let ((nxt (recur (+ i 1))) + (chrsi (string-ref chrs i))) + (lambda (ch) + (or (ch=? chrsi ch) (nxt ch)))))))) + (define (match-set tok nxt) + (let ((chrs (substring tok 1 (- (string-length tok) 1)))) + (if (and (positive? (string-length chrs)) + (memv (string-ref chrs 0) '(#\^ #\!))) + (let ((pred (match-set1 (substring chrs 1 (string-length chrs))))) + (lambda (str k kmatch) + (and (< k (string-length str)) + (not (pred (string-ref str k))) + (nxt str (+ k 1) (cons k kmatch))))) + (let ((pred (match-set1 chrs))) + (lambda (str k kmatch) + (and (< k (string-length str)) + (pred (string-ref str k)) + (nxt str (+ k 1) (cons k kmatch)))))))) + (define (match-* nxt) + (lambda (str k kmatch) + (let ((kmatch (cons k kmatch))) + (let loop ((kk (string-length str))) + (and (>= kk k) + (or (nxt str kk kmatch) + (loop (- kk 1)))))))) + + (let ((matcher + (let recur ((toks (glob:pattern->tokens pat))) + (if (null? toks) + match-end + (let ((pch (or (string=? (car toks) "") + (string-ref (car toks) 0)))) + (case pch + ((#\?) (match-? (recur (cdr toks)))) + ((#\*) (match-* (recur (cdr toks)))) + ((#\[) (match-set (car toks) (recur (cdr toks)))) + (else (match-str (car toks) (recur (cdr toks)))))))))) + (lambda (str) (matcher str 0 '())))) + +(define (glob:caller-with-matches pat proc ch=? ch<=?) + (define (glob:wildcard? pat) + (cond ((string=? pat "") #f) + ((memv (string-ref pat 0) '(#\* #\? #\[)) #t) + (else #f))) + (let* ((toks (glob:pattern->tokens pat)) + (wild? (map glob:wildcard? toks)) + (matcher (glob:make-matcher toks ch=? ch<=?))) + (lambda (str) + (let loop ((inds (matcher str)) + (wild? wild?) + (res '())) + (cond ((not inds) #f) + ((null? wild?) + (apply proc (reverse res))) + ((car wild?) + (loop (cdr inds) + (cdr wild?) + (cons (substring str (car inds) (cadr inds)) res))) + (else + (loop (cdr inds) (cdr wild?) res))))))) + +(define (glob:make-substituter pattern template ch=? ch<=?) + (define (wildcard? pat) + (cond ((string=? pat "") #f) + ((memv (string-ref pat 0) '(#\* #\? #\[)) #t) + (else #f))) + (define (countq val lst) + (do ((lst lst (cdr lst)) + (c 0 (if (eq? val (car lst)) (+ c 1) c))) + ((null? lst) c))) + (let ((tmpl-literals (map (lambda (tok) + (if (wildcard? tok) #f tok)) + (glob:pattern->tokens template))) + (pat-wild? (map wildcard? (glob:pattern->tokens pattern))) + (matcher (glob:make-matcher pattern ch=? ch<=?))) + (or (= (countq #t pat-wild?) (countq #f tmpl-literals)) + (slib:error 'glob:make-substituter + "number of wildcards doesn't match" pattern template)) + (lambda (str) + (let ((indices (matcher str))) + (and indices + (let loop ((inds indices) + (wild? pat-wild?) + (lits tmpl-literals) + (res '())) + (cond + ((null? lits) + (apply string-append (reverse res))) + ((car lits) + (loop inds wild? (cdr lits) (cons (car lits) res))) + ((null? wild?) ;this should never happen. + (loop '() '() lits res)) + ((car wild?) + (loop (cdr inds) (cdr wild?) (cdr lits) + (cons (substring str (car inds) (cadr inds)) + res))) + (else + (loop (cdr inds) (cdr wild?) lits res))))))))) + + +(define (glob:match?? pat) + (glob:make-matcher pat char=? char<=?)) +(define (glob:match-ci?? pat) + (glob:make-matcher pat char-ci=? char-ci<=?)) +(define filename:match?? glob:match??) +(define filename:match-ci?? glob:match-ci??) + +(define (glob:substitute?? pat templ) + (cond ((procedure? templ) + (glob:caller-with-matches pat templ char=? char<=?)) + ((string? templ) + (glob:make-substituter pat templ char=? char<=?)) + (else + (slib:error 'glob:substitute "bad second argument" templ)))) +(define (glob:substitute-ci?? pat templ) + (cond ((procedure? templ) + (glob:caller-with-matches pat templ char-ci=? char-ci<=?)) + ((string? templ) + (glob:make-substituter pat templ char-ci=? char-ci<=?)) + (else + (slib:error 'glob:substitute "bad second argument" templ)))) +(define filename:substitute?? glob:substitute??) +(define filename:substitute-ci?? glob:substitute-ci??) + +(define (replace-suffix str old new) + (let* ((f (glob:make-substituter (list "*" old) (list "*" new) + char=? char<=?)) + (g (lambda (st) + (or (f st) + (slib:error 'replace-suffix "suffix doesn't match:" + old st))))) + (if (pair? str) + (map g str) + (g str)))) diff --git a/module/slib/hash.scm b/module/slib/hash.scm new file mode 100644 index 000000000..ab021388e --- /dev/null +++ b/module/slib/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/module/slib/hashtab.scm b/module/slib/hashtab.scm new file mode 100644 index 000000000..317efe29a --- /dev/null +++ b/module/slib/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/module/slib/htmlform.scm b/module/slib/htmlform.scm new file mode 100644 index 000000000..66bf62ee0 --- /dev/null +++ b/module/slib/htmlform.scm @@ -0,0 +1,448 @@ +;;; "htmlform.scm" Generate HTML 2.0 forms. -*-scheme-*- +; Copyright 1997, 1998, 2000, 2001 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) +(require 'printf) +(require 'parameters) +(require 'object->string) +(require 'string-search) +(require 'database-utilities) +(require 'common-list-functions) + +;;;;@code{(require 'html-form)} +(define html:blank (string->symbol "")) + +;;@body Returns a string with character substitutions appropriate to +;;send @1 as an @dfn{attribute-value}. +(define (html:atval txt) ; attribute-value + (if (symbol? txt) (set! txt (symbol->string txt))) + (if (number? txt) + (number->string txt) + (string-subst (if (string? txt) txt (object->string txt)) + "&" "&" + "\"" """ + "<" "<" + ">" ">"))) + +;;@body Returns a string with character substitutions appropriate to +;;send @1 as an @dfn{plain-text}. +(define (html:plain txt) ; plain-text `Data Characters' + (cond ((eq? html:blank txt) " ") + (else + (if (symbol? txt) (set! txt (symbol->string txt))) + (if (number? txt) + (number->string txt) + (string-subst (if (string? txt) txt (object->string txt)) + "&" "&" + "<" "<" + ">" ">"))))) + +;;@body Returns a tag of meta-information suitable for passing as the +;;third argument to @code{html:head}. The tag produced is @samp{<META +;;NAME="@1" CONTENT="@2">}. The string or symbol @1 can be +;;@samp{author}, @samp{copyright}, @samp{keywords}, @samp{description}, +;;@samp{date}, @samp{robots}, @dots{}. +(define (html:meta name content) + (sprintf #f "\n<META NAME=\"%s\" CONTENT=\"%s\">" name (html:atval content))) + +;;@body Returns a tag of HTTP information suitable for passing as the +;;third argument to @code{html:head}. The tag produced is @samp{<META +;;HTTP-EQUIV="@1" CONTENT="@2">}. The string or symbol @1 can be +;;@samp{Expires}, @samp{PICS-Label}, @samp{Content-Type}, +;;@samp{Refresh}, @dots{}. +(define (html:http-equiv name content) + (sprintf #f "\n<META HTTP-EQUIV=\"%s\" CONTENT=\"%s\">" + name (html:atval content))) + +;;@args delay uri +;;@args delay +;; +;;Returns a tag suitable for passing as the third argument to +;;@code{html:head}. If @2 argument is supplied, then @1 seconds after +;;displaying the page with this tag, Netscape or IE browsers will fetch +;;and display @2. Otherwise, @1 seconds after displaying the page with +;;this tag, Netscape or IE browsers will fetch and redisplay this page. +(define (html:meta-refresh delay . uri) + (if (null? uri) + (sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d\">" delay) + (sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d;URL=%s\">" + delay (car uri)))) + +;;@args title backlink tags ... +;;@args title backlink +;;@args title +;; +;;Returns header string for an HTML page named @1. If @2 is a string, +;;it is used verbatim between the @samp{H1} tags; otherwise @1 is +;;used. If string arguments @3 ... are supplied, then they are +;;included verbatim within the @t{<HEAD>} section. +(define (html:head title . args) + (define backlink (if (null? args) #f (car args))) + (if (not (null? args)) (set! args (cdr args))) + (string-append + (sprintf #f "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\\n") + (sprintf #f "<HTML>\\n") + (sprintf #f "%s" + (html:comment "HTML by SLIB" + "http://swissnet.ai.mit.edu/~jaffer/SLIB.html")) + (sprintf #f " <HEAD>\\n <TITLE>%s</TITLE>\\n %s\\n </HEAD>\\n" + (html:plain title) (apply string-append args)) + (sprintf #f "<BODY><H1>%s</H1>\\n" (or backlink (html:plain title))))) + +;;@body Returns HTML string to end a page. +(define (html:body . body) + (apply string-append + (append body (list (sprintf #f "</BODY>\\n</HTML>\\n"))))) + +;;@body Returns the strings @1, @2 as @dfn{PRE}formmated plain text +;;(rendered in fixed-width font). Newlines are inserted between @1, +;;@2. HTML tags (@samp{<tag>}) within @2 will be visible verbatim. +(define (html:pre line1 . lines) + (sprintf #f "<PRE>\\n%s%s</PRE>" + (html:plain line1) + (string-append + (apply string-append + (map (lambda (line) (sprintf #f "\\n%s" (html:plain line))) + lines))))) + +;;@body Returns the strings @1 as HTML comments. +(define (html:comment line1 . lines) + (string-append + (apply string-append + (if (substring? "--" line1) + (slib:error 'html:comment "line contains --" line1) + (sprintf #f "<!--%s--" line1)) + (map (lambda (line) + (if (substring? "--" line) + (slib:error 'html:comment "line contains --" line) + (sprintf #f "\\n --%s--" line))) + lines)) + (sprintf #f ">\\n"))) + +(define (html:strong-doc name doc) + (set! name (if name (html:plain name) "")) + (set! doc (if doc (html:plain doc) "")) + (if (equal? "" doc) + (if (equal? "" name) + "" + (sprintf #f "<STRONG>%s</STRONG>" (html:plain name))) + (sprintf #f "<STRONG>%s</STRONG> (%s)" + (html:plain name) (html:plain doc)))) + +;;@section HTML Forms + +;;@body The symbol @1 is either @code{get}, @code{head}, @code{post}, +;;@code{put}, or @code{delete}. The strings @3 form the body of the +;;form. @0 returns the HTML @dfn{form}. +(define (html:form method action . body) + (cond ((not (memq method '(get head post put delete))) + (slib:error 'html:form "method unknown:" method))) + (string-append + (apply string-append + (sprintf #f "<FORM METHOD=%#a ACTION=%#a>\\n" + (html:atval method) (html:atval action)) + body) + (sprintf #f "</FORM>\\n"))) + +;;@body Returns HTML string which will cause @1=@2 in form. +(define (html:hidden name value) + (sprintf #f "<INPUT TYPE=HIDDEN NAME=%#a VALUE=%#a>" + (html:atval name) (html:atval value))) + +;;@body Returns HTML string for check box. +(define (html:checkbox pname default) + (sprintf #f "<INPUT TYPE=CHECKBOX NAME=%#a %s>" + (html:atval pname) + (if default "CHECKED" ""))) + +;;@body Returns HTML string for one-line text box. +(define (html:text pname default . size) + (set! size (if (null? size) #f (car size))) + (cond (default + (sprintf #f "<INPUT NAME=%#a SIZE=%d VALUE=%#a>" + (html:atval pname) + (or size + (max 5 + (min 20 (string-length + (if (symbol? default) + (symbol->string default) default))))) + (html:atval default))) + (size (sprintf #f "<INPUT NAME=%#a SIZE=%d>" (html:atval pname) size)) + (else (sprintf #f "<INPUT NAME=%#a>" (html:atval pname))))) + +;;@body Returns HTML string for multi-line text box. +(define (html:text-area pname default-list) + (set! default-list (map (lambda (d) (sprintf #f "%a" d)) default-list)) + (string-append + (sprintf #f "<TEXTAREA NAME=%#a ROWS=%d COLS=%d>\\n" + (html:atval pname) (max 1 (length default-list)) + (min 32 (apply max 5 (map string-length default-list)))) + (let* ((str (apply string-append + (map (lambda (line) + (sprintf #f "%s\\n" (html:plain line))) + default-list))) + (len (+ -1 (string-length str)))) + (if (positive? len) (substring str 0 len) str)) + (sprintf #f "</TEXTAREA>\\n"))) + +(define (html:s<? s1 s2) + (if (and (number? s1) (number? s2)) + (< s1 s2) + (string<? (if (symbol? s1) (symbol->string s1) s1) + (if (symbol? s2) (symbol->string s2) s2)))) + +(define (by-car proc) + (lambda (s1 s2) (proc (car s1) (car s2)))) + +;;@body Returns HTML string for pull-down menu selector. +(define (html:select pname arity default-list foreign-values) + (set! foreign-values (sort foreign-values (by-car html:s<?))) + (let ((value-list (map car foreign-values)) + (visibles (map cadr foreign-values))) + (string-append + (sprintf #f "<SELECT NAME=%#a SIZE=%d%s>" + (html:atval pname) + (case arity + ((single optional) 1) + ((nary nary1) 5)) + (case arity + ((nary nary1) " MULTIPLE") + (else ""))) + (apply string-append + (map (lambda (value visible) + (sprintf #f "<OPTION VALUE=%#a%s>%s" + (html:atval value) + (if (member value default-list) " SELECTED" "") + (html:plain visible))) + (case arity + ((optional nary) (cons html:blank value-list)) + (else value-list)) + (case arity + ((optional nary) (cons html:blank visibles)) + (else visibles)))) + (sprintf #f "</SELECT>")))) + +;;@body Returns HTML string for any-of selector. +(define (html:buttons pname arity default-list foreign-values) + (set! foreign-values (sort foreign-values (by-car html:s<?))) + (let ((value-list (map car foreign-values)) + (visibles (map cadr foreign-values))) + (string-append + (sprintf #f "<MENU>") + (case arity + ((single optional) + (apply + string-append + (map (lambda (value visible) + (sprintf #f + "<LI><INPUT TYPE=RADIO NAME=%#a VALUE=%#a%s> %s\\n" + (html:atval pname) (html:atval value) + (if (member value default-list) " CHECKED" "") + (html:plain visible))) + value-list + visibles))) + ((nary nary1) + (apply + string-append + (map (lambda (value visible) + (sprintf #f + "<LI><INPUT TYPE=CHECKBOX NAME=%#a VALUE=%#a%s> %s\\n" + (html:atval pname) (html:atval value) + (if (member value default-list) " CHECKED" "") + (html:plain visible))) + value-list + visibles)))) + (sprintf #f "</MENU>")))) + +;;@args submit-label command +;;@args submit-label +;; +;;The string or symbol @1 appears on the button which submits the form. +;;If the optional second argument @2 is given, then @code{*command*=@2} +;;and @code{*button*=@1} are set in the query. Otherwise, +;;@code{*command*=@1} is set in the query. +(define (form:submit submit-label . command) + (if (null? command) + (sprintf #f "<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a>" + (html:atval '*command*) + (html:atval submit-label)) + (sprintf #f "%s<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a>" + (html:hidden '*command* (car command)) + (html:atval '*button*) + (html:atval submit-label)))) + +;;@body The @2 appears on the button which submits the form. +(define (form:image submit-label image-src) + (sprintf #f "<INPUT TYPE=IMAGE NAME=%#a SRC=%#a>" + (html:atval submit-label) + (html:atval image-src))) + +;;@body Returns a string which generates a @dfn{reset} button. +(define (form:reset) "<INPUT TYPE=RESET>") + +(define (html:delimited-list . rows) + (apply string-append + "<DL>" + (append rows '("</DL>")))) + +;;@body Returns a string which generates an INPUT element for the field +;;named @1. The element appears in the created form with its +;;representation determined by its @2 and domain. For domains which +;;are foreign-keys: +;; +;;@table @code +;;@item single +;;select menu +;;@item optional +;;select menu +;;@item nary +;;check boxes +;;@item nary1 +;;check boxes +;;@end table +;; +;;If the foreign-key table has a field named @samp{visible-name}, then +;;the contents of that field are the names visible to the user for +;;those choices. Otherwise, the foreign-key itself is visible. +;; +;;For other types of domains: +;; +;;@table @code +;;@item single +;;text area +;;@item optional +;;text area +;;@item boolean +;;check box +;;@item nary +;;text area +;;@item nary1 +;;text area +;;@end table +(define (form:element pname arity default-list foreign-values) + (define dflt (if (null? default-list) #f + (sprintf #f "%a" (car default-list)))) + ;;(print 'form:element pname arity default-list foreign-values) + (case (length foreign-values) + ((0) (case arity + ((boolean) + (html:checkbox pname dflt)) + ((single optional) + (html:text pname (if (car default-list) dflt ""))) + (else (html:text-area pname default-list)))) + ((1) (html:checkbox pname dflt)) + (else ((case arity + ((single optional) html:select) + (else html:buttons)) + pname arity default-list foreign-values)))) + +;;@body +;; +;;Returns a HTML string for a form element embedded in a line of a +;;delimited list. Apply map @0 to the list returned by +;;@code{command->p-specs}. +(define (form:delimited pname doc aliat arity default-list foreign-values) + (define longname + (remove-if (lambda (s) (= 1 (string-length s))) (cdr aliat))) + (set! longname (if (null? longname) #f (car longname))) + (if longname + (string-append + "<DT>" (html:strong-doc longname doc) "<DD>" + (form:element pname arity default-list foreign-values)) + "")) + +;;@body +;; +;;The symbol @2 names a command table in the @1 relational database. +;;The symbol @3 names a key in @2. +;; +;;@0 returns a list of lists of @var{pname}, @var{doc}, @var{aliat}, +;;@var{arity}, @var{default-list}, and @var{foreign-values}. The +;;returned list has one element for each parameter of command @3. +;; +;;This example demonstrates how to create a HTML-form for the @samp{build} +;;command. +;; +;;@example +;;(require (in-vicinity (implementation-vicinity) "build.scm")) +;;(call-with-output-file "buildscm.html" +;; (lambda (port) +;; (display +;; (string-append +;; (html:head 'commands) +;; (html:body +;; (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n" +;; (html:plain 'build) +;; (html:plain ((comtab 'get 'documentation) 'build))) +;; (html:form +;; 'post +;; (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") +;; (apply html:delimited-list +;; (apply map form:delimited +;; (command->p-specs build '*commands* 'build))) +;; (form:submit 'build) +;; (form:reset)))) +;; port))) +;;@end example +(define (command->p-specs rdb command-table command) + (define rdb-open (rdb 'open-table)) + (define (row-refer idx) (lambda (row) (list-ref row idx))) + (let ((comtab (rdb-open command-table #f)) + ;;(domain->type ((rdb-open '*domains-data* #f) 'get 'type-id)) + (get-foreign-values + (let ((ftn ((rdb-open '*domains-data* #f) 'get 'foreign-table))) + (lambda (domain-name) + (define tab-name (ftn domain-name)) + (if tab-name + (get-foreign-choices (rdb-open tab-name #f)) + '()))))) + (define row-ref + (let ((names (comtab 'column-names))) + (lambda (row name) (list-ref row (position name names))))) + (let* ((command:row ((comtab 'row:retrieve) command)) + (parameter-table (rdb-open (row-ref command:row 'parameters) #f)) + (pcnames (parameter-table 'column-names)) + (param-rows (sort! ((parameter-table 'row:retrieve*)) + (lambda (r1 r2) (< (car r1) (car r2)))))) + (let ((domains (map (row-refer (position 'domain pcnames)) param-rows)) + (parameter-names (rdb-open (row-ref command:row 'parameter-names) #f)) + (pnames (map (row-refer (position 'name pcnames)) param-rows))) + (define foreign-values (map get-foreign-values domains)) + (define aliast (map list pnames)) + (for-each (lambda (alias) + (if (> (string-length (car alias)) 1) + (let ((apr (assq (cadr alias) aliast))) + (set-cdr! apr (cons (car alias) (cdr apr)))))) + (map list + ((parameter-names 'get* 'name)) + (map (parameter-table 'get 'name) + ((parameter-names 'get* 'parameter-index))))) + (list pnames + (map (row-refer (position 'documentation pcnames)) param-rows) + aliast + (map (row-refer (position 'arity pcnames)) param-rows) + ;;(map domain->type domains) + (map cdr ;(lambda (lst) (if (null? lst) lst (cdr lst))) + (fill-empty-parameters + (map slib:eval + (map (row-refer (position 'defaulter pcnames)) + param-rows)) + (make-parameter-list + (map (row-refer (position 'name pcnames)) param-rows)))) + foreign-values))))) diff --git a/module/slib/htmlform.txi b/module/slib/htmlform.txi new file mode 100644 index 000000000..f5ed48b92 --- /dev/null +++ b/module/slib/htmlform.txi @@ -0,0 +1,204 @@ +@code{(require 'html-form)} + + +@defun html:atval txt +Returns a string with character substitutions appropriate to +send @var{txt} as an @dfn{attribute-value}. +@cindex attribute-value +@end defun + +@defun html:plain txt +Returns a string with character substitutions appropriate to +send @var{txt} as an @dfn{plain-text}. +@cindex plain-text +@end defun + +@defun html:meta name content +Returns a tag of meta-information suitable for passing as the +third argument to @code{html:head}. The tag produced is @samp{<META +NAME="@var{name}" CONTENT="@var{content}">}. The string or symbol @var{name} can be +@samp{author}, @samp{copyright}, @samp{keywords}, @samp{description}, +@samp{date}, @samp{robots}, @dots{}. +@end defun + +@defun html:http-equiv name content +Returns a tag of HTTP information suitable for passing as the +third argument to @code{html:head}. The tag produced is @samp{<META +HTTP-EQUIV="@var{name}" CONTENT="@var{content}">}. The string or symbol @var{name} can be +@samp{Expires}, @samp{PICS-Label}, @samp{Content-Type}, +@samp{Refresh}, @dots{}. +@end defun + +@defun html:meta-refresh delay uri + + +@defunx html:meta-refresh delay + +Returns a tag suitable for passing as the third argument to +@code{html:head}. If @var{uri} argument is supplied, then @var{delay} seconds after +displaying the page with this tag, Netscape or IE browsers will fetch +and display @var{uri}. Otherwise, @var{delay} seconds after displaying the page with +this tag, Netscape or IE browsers will fetch and redisplay this page. +@end defun + +@defun html:head title backlink tags @dots{} + + +@defunx html:head title backlink + +@defunx html:head title + +Returns header string for an HTML page named @var{title}. If @var{backlink} is a string, +it is used verbatim between the @samp{H1} tags; otherwise @var{title} is +used. If string arguments @var{tags} ... are supplied, then they are +included verbatim within the @t{<HEAD>} section. +@end defun + +@defun html:body body @dots{} +Returns HTML string to end a page. +@end defun + +@defun html:pre line1 line @dots{} +Returns the strings @var{line1}, @var{lines} as @dfn{PRE}formmated plain text +@cindex PRE +(rendered in fixed-width font). Newlines are inserted between @var{line1}, +@var{lines}. HTML tags (@samp{<tag>}) within @var{lines} will be visible verbatim. +@end defun + +@defun html:comment line1 line @dots{} +Returns the strings @var{line1} as HTML comments. +@end defun +@section HTML Forms + + +@defun html:form method action body @dots{} +The symbol @var{method} is either @code{get}, @code{head}, @code{post}, +@code{put}, or @code{delete}. The strings @var{body} form the body of the +form. @code{html:form} returns the HTML @dfn{form}. +@cindex form +@end defun + +@defun html:hidden name value +Returns HTML string which will cause @var{name}=@var{value} in form. +@end defun + +@defun html:checkbox pname default +Returns HTML string for check box. +@end defun + +@defun html:text pname default size @dots{} +Returns HTML string for one-line text box. +@end defun + +@defun html:text-area pname default-list +Returns HTML string for multi-line text box. +@end defun + +@defun html:select pname arity default-list foreign-values +Returns HTML string for pull-down menu selector. +@end defun + +@defun html:buttons pname arity default-list foreign-values +Returns HTML string for any-of selector. +@end defun + +@defun form:submit submit-label command + + +@defunx form:submit submit-label + +The string or symbol @var{submit-label} appears on the button which submits the form. +If the optional second argument @var{command} is given, then @code{*command*=@var{command}} +and @code{*button*=@var{submit-label}} are set in the query. Otherwise, +@code{*command*=@var{submit-label}} is set in the query. +@end defun + +@defun form:image submit-label image-src +The @var{image-src} appears on the button which submits the form. +@end defun + +@defun form:reset +Returns a string which generates a @dfn{reset} button. +@cindex reset +@end defun + +@defun form:element pname arity default-list foreign-values +Returns a string which generates an INPUT element for the field +named @var{pname}. The element appears in the created form with its +representation determined by its @var{arity} and domain. For domains which +are foreign-keys: + +@table @code +@item single +select menu +@item optional +select menu +@item nary +check boxes +@item nary1 +check boxes +@end table + +If the foreign-key table has a field named @samp{visible-name}, then +the contents of that field are the names visible to the user for +those choices. Otherwise, the foreign-key itself is visible. + +For other types of domains: + +@table @code +@item single +text area +@item optional +text area +@item boolean +check box +@item nary +text area +@item nary1 +text area +@end table +@end defun + +@defun form:delimited pname doc aliat arity default-list foreign-values + + +Returns a HTML string for a form element embedded in a line of a +delimited list. Apply map @code{form:delimited} to the list returned by +@code{command->p-specs}. +@end defun + +@defun command->p-specs rdb command-table command + + +The symbol @var{command-table} names a command table in the @var{rdb} relational database. +The symbol @var{command} names a key in @var{command-table}. + +@code{command->p-specs} returns a list of lists of @var{pname}, @var{doc}, @var{aliat}, +@var{arity}, @var{default-list}, and @var{foreign-values}. The +returned list has one element for each parameter of command @var{command}. + +This example demonstrates how to create a HTML-form for the @samp{build} +command. + +@example +(require (in-vicinity (implementation-vicinity) "build.scm")) +(call-with-output-file "buildscm.html" + (lambda (port) + (display + (string-append + (html:head 'commands) + (html:body + (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n" + (html:plain 'build) + (html:plain ((comtab 'get 'documentation) 'build))) + (html:form + 'post + (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") + (apply html:delimited-list + (apply map form:delimited + (command->p-specs build '*commands* 'build))) + (form:submit 'build) + (form:reset)))) + port))) +@end example +@end defun diff --git a/module/slib/http-cgi.scm b/module/slib/http-cgi.scm new file mode 100644 index 000000000..05a1f6bf2 --- /dev/null +++ b/module/slib/http-cgi.scm @@ -0,0 +1,438 @@ +;;; "http-cgi.scm" service HTTP or CGI requests. -*-scheme-*- +; Copyright 1997, 1998, 2000, 2001 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 'uri) +(require 'scanf) +(require 'printf) +(require 'coerce) +(require 'line-i/o) +(require 'html-form) +(require 'parameters) +(require 'string-case) + +;;@code{(require 'http)} or @code{(require 'cgi)} + +(define http:crlf (string (integer->char 13) #\newline)) +(define (http:read-header port) + (define alist '()) + (do ((line (read-line port) (read-line port))) + ((or (zero? (string-length line)) + (and (= 1 (string-length line)) + (char-whitespace? (string-ref line 0))) + (eof-object? line)) + (if (and (= 1 (string-length line)) + (char-whitespace? (string-ref line 0))) + (set! http:crlf (string (string-ref line 0) #\newline))) + (if (eof-object? line) line alist)) + (let ((len (string-length line)) + (idx (string-index line #\:))) + (if (char-whitespace? (string-ref line (+ -1 len))) + (set! len (+ -1 len))) + (and idx (do ((idx2 (+ idx 1) (+ idx2 1))) + ((or (>= idx2 len) + (not (char-whitespace? (string-ref line idx2)))) + (set! alist + (cons + (cons (string-ci->symbol (substring line 0 idx)) + (substring line idx2 len)) + alist))))) + ;;Else -- ignore malformed line + ;;(else (slib:error 'http:read-header 'malformed-input line)) + ))) + +(define (http:read-query-string request-line header port) + (case (car request-line) + ((get head) + (let* ((request-uri (cadr request-line)) + (len (string-length request-uri))) + (and (> len 3) + (string-index request-uri #\?) + (substring request-uri + (+ 1 (string-index request-uri #\?)) + (if (eqv? #\/ (string-ref request-uri (+ -1 len))) + (+ -1 len) + len))))) + ((post put delete) + (let ((content-length (assq 'content-length header))) + (and content-length + (set! content-length (string->number (cdr content-length)))) + (and content-length + (let ((str (make-string content-length #\ ))) + (do ((idx 0 (+ idx 1))) + ((>= idx content-length) + (if (>= idx (string-length str)) str (substring str 0 idx))) + (let ((chr (read-char port))) + (if (char? chr) + (string-set! str idx chr) + (set! content-length idx)))))))) + (else #f))) + +(define (http:status-line status-code reason) + (sprintf #f "HTTP/1.1 %d %s%s" status-code reason http:crlf)) + +;;@body Returns a string containing lines for each element of @1; the +;;@code{car} of which is followed by @samp{: }, then the @code{cdr}. +(define (http:header alist) + (string-append + (apply string-append + (map (lambda (pair) + (sprintf #f "%s: %s%s" (car pair) (cdr pair) http:crlf)) + alist)) + http:crlf)) + +;;@body Returns the concatenation of strings @2 with the +;;@code{(http:header @1)} and the @samp{Content-Length} prepended. +(define (http:content alist . body) + (define hunk (apply string-append body)) + (string-append (http:header + (cons (cons "Content-Length" + (number->string (string-length hunk))) + alist)) + hunk)) + +;;@body String appearing at the bottom of error pages. +(define *http:byline* #f) + +;;@body @1 and @2 should be an integer and string as specified in +;;@cite{RFC 2068}. The returned page (string) will show the @1 and @2 +;;and any additional @3 @dots{}; with @var{*http:byline*} or SLIB's +;;default at the bottom. +(define (http:error-page status-code reason-phrase . html-strings) + (define byline + (or + *http:byline* + (sprintf + #f + "<A HREF=http://swissnet.ai.mit.edu/~jaffer/SLIB.html>SLIB</A> %s server" + (if (getenv "SERVER_PROTOCOL") "CGI/1.1" "HTTP/1.1")))) + (string-append (http:status-line status-code reason-phrase) + (http:content + '(("Content-Type" . "text/html")) + (html:head (sprintf #f "%d %s" status-code reason-phrase)) + (apply html:body + (append html-strings + (list (sprintf #f "<HR>\\n%s\\n" byline))))))) + +;;@body The string or symbol @1 is the page title. @2 is a non-negative +;;integer. The @4 @dots{} are typically used to explain to the user why +;;this page is being forwarded. +;; +;;@0 returns an HTML string for a page which automatically forwards to +;;@3 after @2 seconds. The returned page (string) contains any @4 +;;@dots{} followed by a manual link to @3, in case the browser does not +;;forward automatically. +(define (http:forwarding-page title delay uri . html-strings) + (string-append + (html:head title #f (html:meta-refresh delay uri)) + (apply html:body + (append html-strings + (list (sprintf #f "\\n\\n<HR>\\nReturn to %s.\\n" + (html:link uri title))))))) + +;;@body reads the @dfn{URI} and @dfn{query-string} from @2. If the +;;query is a valid @samp{"POST"} or @samp{"GET"} query, then @0 calls +;;@1 with three arguments, the @var{request-line}, @var{query-string}, +;;and @var{header-alist}. Otherwise, @0 calls @1 with the +;;@var{request-line}, #f, and @var{header-alist}. +;; +;;If @1 returns a string, it is sent to @3. If @1 returns a list, +;;then an error page with number 525 and strings from the list. If @1 +;;returns #f, then a @samp{Bad Request} (400) page is sent to @3. +;; +;;Otherwise, @0 replies (to @3) with appropriate HTML describing the +;;problem. +(define (http:serve-query serve-proc input-port output-port) + (let* ((request-line (http:read-request-line input-port)) + (header (and request-line (http:read-header input-port))) + (query-string (and header (http:read-query-string + request-line header input-port)))) + (display (http:service serve-proc request-line query-string header) + output-port))) + +(define (http:service serve-proc request-line query-string header) + (cond ((not request-line) (http:error-page 400 "Bad Request.")) + ((string? (car request-line)) + (http:error-page 501 "Not Implemented" (html:plain request-line))) + ((not (memq (car request-line) '(get post))) + (http:error-page 405 "Method Not Allowed" (html:plain request-line))) + ((serve-proc request-line query-string header) => + (lambda (reply) + (cond ((string? reply) + (string-append (http:status-line 200 "OK") + reply)) + ((and (pair? reply) (list? reply)) + (if (number? (car reply)) + (apply http:error-page reply) + (apply http:error-page 525 reply))) + (else (http:error-page 500 "Internal Server Error"))))) + ((not query-string) + (http:error-page 400 "Bad Request" (html:plain request-line))) + (else + (http:error-page 500 "Internal Server Error" (html:plain header))))) + +;;@ +;; +;;This example services HTTP queries from @var{port-number}: +;;@example +;; +;;(define socket (make-stream-socket AF_INET 0)) +;;(and (socket:bind socket port-number) ; AF_INET INADDR_ANY +;; (socket:listen socket 10) ; Queue up to 10 requests. +;; (dynamic-wind +;; (lambda () #f) +;; (lambda () +;; (do ((port (socket:accept socket) (socket:accept socket))) +;; (#f) +;; (let ((iport (duplicate-port port "r")) +;; (oport (duplicate-port port "w"))) +;; (http:serve-query build:serve iport oport) +;; (close-port iport) +;; (close-port oport)) +;; (close-port port))) +;; (lambda () (close-port socket)))) +;;@end example + +(define (http:read-start-line port) + (do ((line (read-line port) (read-line port))) + ((or (not (equal? "" line)) (eof-object? line)) line))) + +;; @body +;; Request lines are a list of three itmes: +;; +;; @enumerate 0 +;; +;; @item Method +;; +;; A symbol (@code{options}, @code{get}, @code{head}, @code{post}, +;; @code{put}, @code{delete}, @code{trace} @dots{}). +;; +;; @item Request-URI +;; +;; A string. For direct HTTP, at the minimum it will be the string +;; @samp{"/"}. +;; +;; @item HTTP-Version +;; +;; A string. For example, @samp{HTTP/1.0}. +;; @end enumerate +(define (http:read-request-line port) + (let ((lst (scanf-read-list "%s %s %s %s" (http:read-start-line port)))) + (and (list? lst) + (= 3 (length lst)) + (cons (string-ci->symbol (car lst)) (cdr lst))))) +(define (cgi:request-line) + (define method (getenv "REQUEST_METHOD")) + (and method + (list (string-ci->symbol method) + (getenv "SCRIPT_NAME") + (getenv "SERVER_PROTOCOL")))) + +(define (cgi:query-header) + (define assqs '()) + (cond ((and (getenv "SERVER_NAME") (getenv "SERVER_PORT")) + (set! assqs (cons (cons 'host (string-append (getenv "SERVER_NAME") + ":" + (getenv "SERVER_PORT"))) + assqs)))) + (for-each + (lambda (envar) + (define valstr (getenv envar)) + (if valstr (set! assqs + (cons (cons (string-ci->symbol + (string-subst envar "HTTP_" "" "_" "-")) + valstr) + assqs)))) + '( + ;;"AUTH_TYPE" + "CONTENT_LENGTH" + "CONTENT_TYPE" + "DOCUMENT_ROOT" + "GATEWAY_INTERFACE" + "HTTP_ACCEPT" + "HTTP_ACCEPT_CHARSET" + "HTTP_ACCEPT_ENCODING" + "HTTP_ACCEPT_LANGUAGE" + "HTTP_CONNECTION" + "HTTP_HOST" + ;;"HTTP_PRAGMA" + "HTTP_REFERER" + "HTTP_USER_AGENT" + "PATH_INFO" + "PATH_TRANSLATED" + "QUERY_STRING" + "REMOTE_ADDR" + "REMOTE_HOST" + ;;"REMOTE_IDENT" + ;;"REMOTE_USER" + "REQUEST_URI" + "SCRIPT_FILENAME" + "SCRIPT_NAME" + ;;"SERVER_SIGNATURE" + ;;"SERVER_SOFTWARE" + )) + assqs) + +;; @body Reads the @dfn{query-string} from @code{(current-input-port)}. +;; @0 reads a @samp{"POST"} or @samp{"GET"} queries, depending on the +;; value of @code{(getenv "REQUEST_METHOD")}. +(define (cgi:read-query-string) + (define request-method (getenv "REQUEST_METHOD")) + (cond ((and request-method (string-ci=? "GET" request-method)) + (getenv "QUERY_STRING")) + ((and request-method (string-ci=? "POST" request-method)) + (let ((content-length (getenv "CONTENT_LENGTH"))) + (and content-length + (set! content-length (string->number content-length))) + (and content-length + (let ((str (make-string content-length #\ ))) + (do ((idx 0 (+ idx 1))) + ((>= idx content-length) + (if (>= idx (string-length str)) + str + (substring str 0 idx))) + (let ((chr (read-char))) + (if (char? chr) + (string-set! str idx chr) + (set! content-length idx)))))))) + (else #f))) + +;;@body reads the @dfn{URI} and @dfn{query-string} from +;;@code{(current-input-port)}. If the query is a valid @samp{"POST"} +;;or @samp{"GET"} query, then @0 calls @1 with three arguments, the +;;@var{request-line}, @var{query-string}, and @var{header-alist}. +;;Otherwise, @0 calls @1 with the @var{request-line}, #f, and +;;@var{header-alist}. +;; +;;If @1 returns a string, it is sent to @code{(current-input-port)}. +;;If @1 returns a list, then an error page with number 525 and strings +;;from the list. If @1 returns #f, then a @samp{Bad Request} (400) +;;page is sent to @code{(current-input-port)}. +;; +;;Otherwise, @0 replies (to @code{(current-input-port)}) with +;;appropriate HTML describing the problem. +(define (cgi:serve-query serve-proc) + (let* ((script-name (getenv "SCRIPT_NAME")) + (request-line (cgi:request-line)) + (header (and request-line (cgi:query-header))) + (query-string (and header (cgi:read-query-string))) + (reply (http:service serve-proc request-line query-string header))) + (display (if (and script-name + (not (eqv? 0 (substring? "nph-" script-name)))) + ;; Eat http status line. + (substring reply (+ 2 (substring? http:crlf reply)) + (string-length reply)) + reply)))) + +(define (coerce->list str type) + (case type + ((expression) + (slib:warn 'coerce->list 'unsafe 'read) + (do ((tok (read port) (read port)) + (lst '() (cons tok lst))) + ((or (null? tok) (eof-object? tok)) lst))) + ((symbol) + (call-with-input-string str + (lambda (port) + (do ((tok (scanf-read-list " %s" port) + (scanf-read-list " %s" port)) + (lst '() (cons (string-ci->symbol (car tok)) lst))) + ((or (null? tok) (eof-object? tok)) lst))))) + (else + (call-with-input-string str + (lambda (port) + (do ((tok (scanf-read-list " %s" port) + (scanf-read-list " %s" port)) + (lst '() (cons (coerce (car tok) type) lst))) + ((or (null? tok) (eof-object? tok)) lst))))))) + +(define (query-alist->parameter-list alist optnames arities types) + (let ((parameter-list (make-parameter-list optnames))) + (for-each + (lambda (lst) + (let* ((value (cadr lst)) + (name (car lst)) + (opt-pos (position name optnames))) + (cond ((not opt-pos) + (slib:warn 'query-alist->parameter-list + 'unknown 'parameter name)) + ((eq? (list-ref arities opt-pos) 'boolean) + (adjoin-parameters! parameter-list (list name #t))) + ((and (equal? value "") + (not (memq (list-ref types opt-pos) '(expression string)))) + (adjoin-parameters! parameter-list (list name #f))) + (value + (adjoin-parameters! + parameter-list + (cons name + (case (list-ref arities opt-pos) + ((nary nary1) + (coerce->list value (list-ref types opt-pos))) + (else + (list (coerce value (list-ref types opt-pos))))))))))) + alist) + parameter-list)) + +;;@args rdb command-table +;;@args rdb command-table #t +;; +;;Returns a procedure of one argument. When that procedure is called +;;with a @var{query-alist} (as returned by @code{uri:decode-query}, the +;;value of the @samp{*command*} association will be the command invoked +;;in @2. If @samp{*command*} is not in the @var{query-alist} then the +;;value of @samp{*suggest*} is tried. If neither name is in the +;;@var{query-alist}, then the literal value @samp{*default*} is tried in +;;@2. +;; +;;If optional third argument is non-false, then the command is called +;;with just the parameter-list; otherwise, command is called with the +;;arguments described in its table. +(define (make-query-alist-command-server rdb command-table . just-params?) + (define comsrvcal (make-command-server rdb command-table)) + (set! just-params? (if (null? just-params?) #f (car just-params?))) + (lambda (query-alist) + (define comnam #f) + (define find-command? + (lambda (cname) + (define tryp (parameter-list-ref query-alist cname)) + (cond ((not tryp) #f) + (comnam + (set! query-alist (remove-parameter cname query-alist))) + (else + (set! query-alist (remove-parameter cname query-alist)) + (set! comnam (string-ci->symbol (car tryp))))))) + (find-command? '*command*) + (find-command? '*suggest*) + (find-command? '*button*) + (cond ((not comnam) (set! comnam '*default*))) + (cond + (comnam + (comsrvcal comnam + (lambda (comname comval options positions + arities types defaulters dirs aliases) + (let* ((params (query-alist->parameter-list + query-alist options arities types)) + (fparams (fill-empty-parameters defaulters params))) + (and (list? fparams) + (check-parameters dirs fparams) + (if just-params? + (comval fparams) + (let ((arglist (parameter-list->arglist + positions arities fparams))) + (and arglist + (apply comval arglist)))))))))))) diff --git a/module/slib/http-cgi.txi b/module/slib/http-cgi.txi new file mode 100644 index 000000000..1522d9cec --- /dev/null +++ b/module/slib/http-cgi.txi @@ -0,0 +1,110 @@ +@code{(require 'http)} or @code{(require 'cgi)} + + +@defun http:header alist +Returns a string containing lines for each element of @var{alist}; the +@code{car} of which is followed by @samp{: }, then the @code{cdr}. +@end defun + +@defun http:content alist body @dots{} +Returns the concatenation of strings @var{body} with the +@code{(http:header @var{alist})} and the @samp{Content-Length} prepended. +@end defun + +@defvar *http:byline* +String appearing at the bottom of error pages. +@end defvar + +@defun http:error-page status-code reason-phrase html-string @dots{} +@var{status-code} and @var{reason-phrase} should be an integer and string as specified in +@cite{RFC 2068}. The returned page (string) will show the @var{status-code} and @var{reason-phrase} +and any additional @var{html-strings} @dots{}; with @var{*http:byline*} or SLIB's +default at the bottom. +@end defun + +@defun http:forwarding-page title delay uri html-string @dots{} +The string or symbol @var{title} is the page title. @var{delay} is a non-negative +integer. The @var{html-strings} @dots{} are typically used to explain to the user why +this page is being forwarded. + +@code{http:forwarding-page} returns an HTML string for a page which automatically forwards to +@var{uri} after @var{delay} seconds. The returned page (string) contains any @var{html-strings} +@dots{} followed by a manual link to @var{uri}, in case the browser does not +forward automatically. +@end defun + +@defun http:serve-query serve-proc input-port output-port +reads the @dfn{URI} and @dfn{query-string} from @var{input-port}. If the +@cindex URI +@cindex query-string +query is a valid @samp{"POST"} or @samp{"GET"} query, then @code{http:serve-query} calls +@var{serve-proc} with three arguments, the @var{request-line}, @var{query-string}, +and @var{header-alist}. Otherwise, @code{http:serve-query} calls @var{serve-proc} with the +@var{request-line}, #f, and @var{header-alist}. + +If @var{serve-proc} returns a string, it is sent to @var{output-port}. If @var{serve-proc} returns a list, +then an error page with number 525 and strings from the list. If @var{serve-proc} +returns #f, then a @samp{Bad Request} (400) page is sent to @var{output-port}. + +Otherwise, @code{http:serve-query} replies (to @var{output-port}) with appropriate HTML describing the +problem. +@end defun + + +This example services HTTP queries from @var{port-number}: +@example + +(define socket (make-stream-socket AF_INET 0)) +(and (socket:bind socket port-number) ; AF_INET INADDR_ANY + (socket:listen socket 10) ; Queue up to 10 requests. + (dynamic-wind + (lambda () #f) + (lambda () + (do ((port (socket:accept socket) (socket:accept socket))) + (#f) + (let ((iport (duplicate-port port "r")) + (oport (duplicate-port port "w"))) + (http:serve-query build:serve iport oport) + (close-port iport) + (close-port oport)) + (close-port port))) + (lambda () (close-port socket)))) +@end example + + +@defun cgi:serve-query serve-proc +reads the @dfn{URI} and @dfn{query-string} from +@cindex URI +@cindex query-string +@code{(current-input-port)}. If the query is a valid @samp{"POST"} +or @samp{"GET"} query, then @code{cgi:serve-query} calls @var{serve-proc} with three arguments, the +@var{request-line}, @var{query-string}, and @var{header-alist}. +Otherwise, @code{cgi:serve-query} calls @var{serve-proc} with the @var{request-line}, #f, and +@var{header-alist}. + +If @var{serve-proc} returns a string, it is sent to @code{(current-input-port)}. +If @var{serve-proc} returns a list, then an error page with number 525 and strings +from the list. If @var{serve-proc} returns #f, then a @samp{Bad Request} (400) +page is sent to @code{(current-input-port)}. + +Otherwise, @code{cgi:serve-query} replies (to @code{(current-input-port)}) with +appropriate HTML describing the problem. +@end defun + +@defun make-query-alist-command-server rdb command-table + + +@defunx make-query-alist-command-server rdb command-table #t + +Returns a procedure of one argument. When that procedure is called +with a @var{query-alist} (as returned by @code{uri:decode-query}, the +value of the @samp{*command*} association will be the command invoked +in @var{command-table}. If @samp{*command*} is not in the @var{query-alist} then the +value of @samp{*suggest*} is tried. If neither name is in the +@var{query-alist}, then the literal value @samp{*default*} is tried in +@var{command-table}. + +If optional third argument is non-false, then the command is called +with just the parameter-list; otherwise, command is called with the +arguments described in its table. +@end defun diff --git a/module/slib/lineio.scm b/module/slib/lineio.scm new file mode 100644 index 000000000..caf6a800d --- /dev/null +++ b/module/slib/lineio.scm @@ -0,0 +1,82 @@ +; "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. + + +;;@args +;;@args 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. The @var{port} argument may be +;;omitted, in which case it defaults to the value returned by +;;@code{current-input-port}. +(define (read-line . port) + (let* ((char (apply read-char port))) + (if (eof-object? char) + char + (do ((char char (apply read-char port)) + (clist '() (cons char clist))) + ((or (eof-object? char) (char=? #\newline char)) + (list->string (reverse clist))))))) + +;;@args string +;;@args string port +;;Fills @1 with characters up to, but not including a newline or end +;;of file, updating the @var{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. The @var{port} argument may be +;;omitted, in which case it defaults to the value returned by +;;@code{current-input-port}. +(define (read-line! str . port) + (let* ((char (apply read-char port)) + (midx (+ -1 (string-length str)))) + (if (eof-object? char) + char + (do ((char char (apply read-char port)) + (i 0 (+ 1 i))) + ((or (eof-object? char) + (char=? #\newline char) + (> i midx)) + (if (> i midx) #f i)) + (string-set! str i char))))) + +;;@args string +;;@args string port +;;Writes @1 followed by a newline to the given @var{port} and returns +;;an unspecified value. The @var{Port} argument may be omitted, in +;;which case it defaults to the value returned by +;;@code{current-input-port}.@refill +(define (write-line str . port) + (apply display str port) + (apply newline port)) + +;;@args path +;;@args path port +;;Displays the contents of the file named by @1 to @var{port}. The +;;@var{port} argument may be ommited, in which case it defaults to the +;;value returned by @code{current-output-port}. +(define (display-file path . port) + (set! port (if (null? port) (current-output-port) (car port))) + (call-with-input-file path + (lambda (inport) + (do ((line (read-line inport) (read-line inport))) + ((eof-object? line)) + (write-line line port))))) diff --git a/module/slib/lineio.txi b/module/slib/lineio.txi new file mode 100644 index 000000000..34d42d586 --- /dev/null +++ b/module/slib/lineio.txi @@ -0,0 +1,45 @@ + +@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. The @var{port} argument may be +omitted, in which case it defaults to the value returned by +@code{current-input-port}. +@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 @var{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. The @var{port} argument may be +omitted, in which case it defaults to the value returned by +@code{current-input-port}. +@end defun + +@defun write-line string + + +@defunx write-line string port +Writes @var{string} followed by a newline to the given @var{port} and returns +an unspecified value. The @var{Port} argument may be omitted, in +which case it defaults to the value returned by +@code{current-input-port}.@refill +@end defun + +@defun display-file path + + +@defunx display-file path port +Displays the contents of the file named by @var{path} to @var{port}. The +@var{port} argument may be ommited, in which case it defaults to the +value returned by @code{current-output-port}. +@end defun diff --git a/module/slib/logical.scm b/module/slib/logical.scm new file mode 100644 index 000000000..c85507dab --- /dev/null +++ b/module/slib/logical.scm @@ -0,0 +1,168 @@ +;;;; "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:copy-bit index to bool) + (if bool + (logical:logior to (logical:ash 1 index)) + (logical:logand to (logical:lognot (logical:ash 1 index))))) + +(define (logical:bit-field n start end) + (logical:logand (- (logical:integer-expt 2 (- end start)) 1) + (logical:ash n (- start)))) + +(define (logical:bitwise-if mask n0 n1) + (logical:logior (logical:logand mask n0) + (logical:logand (logical:lognot mask) n1))) + +(define (logical:copy-bit-field to start end from) + (logical:bitwise-if + (logical:ash (- (logical:integer-expt 2 (- end start)) 1) start) + (logical:ash from start) + to)) + +(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 copy-bit logical:copy-bit) +(define ash logical:ash) +(define logcount logical:logcount) +(define integer-length logical:integer-length) +(define bit-field logical:bit-field) +(define bit-extract logical:bit-field) +(define copy-bit-field logical:copy-bit-field) +(define ipow-by-squaring logical:ipow-by-squaring) +(define integer-expt logical:integer-expt) diff --git a/module/slib/macrotst.scm b/module/slib/macrotst.scm new file mode 100644 index 000000000..b5b504602 --- /dev/null +++ b/module/slib/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/module/slib/macscheme.init b/module/slib/macscheme.init new file mode 100644 index 000000000..e85095571 --- /dev/null +++ b/module/slib/macscheme.init @@ -0,0 +1,276 @@ +;;;"macscheme.init" Configuration of *features* for MacScheme -*-scheme-*- +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. + +;;; 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-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) #f) + +;;; (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:") + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define (home-vicinity) #f) + +;;; *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 +; 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)) + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; 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) + +;;; 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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;;; define an error procedure for the library +(define slib:error + (lambda args + (if (provided? 'trace) (print-call-stack (current-error-port))) + (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/module/slib/macwork.scm b/module/slib/macwork.scm new file mode 100644 index 000000000..6336ae53e --- /dev/null +++ b/module/slib/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/module/slib/makcrc.scm b/module/slib/makcrc.scm new file mode 100644 index 000000000..39abe7c36 --- /dev/null +++ b/module/slib/makcrc.scm @@ -0,0 +1,96 @@ +;;;; "makcrc.scm" Compute Cyclic Checksums +;;; Copyright (C) 1995, 1996, 1997, 2001 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 'byte) +(require 'logical) + +(define (make-port-crc . margs) + (define (make-mask hibit) + (+ (ash (+ -1 (ash 1 (+ 1 (- hibit 2)))) 1) 1)) + (define chunk-bits (integer-length (+ -1 char-code-limit))) + (define accum-bits #f) + (define generator #f) + (case (length margs) + ((0) #t) + ((1) (if (< (car margs) 128) + (set! accum-bits (car margs)) + (set! generator (car margs)))) + ((2) + (set! accum-bits (car margs)) + (set! generator (cadr margs))) + (else (slib:error 'make-port-crc 'args margs))) + (cond ((not generator) + (case accum-bits + ((#f 32) (set! accum-bits 32) + (set! generator #b00000100110000010001110110110111)) ; CRC-32 + ((16) (set! generator #b0001000000001011)) ; CRC-16 + ;;((16) (set! generator #b0001000000100001)) ; CRC-CCIT + ;;((08) (set! generator #b101011)) + (else (slib:error 'make-port-crc "no default polynomial for" + accum-bits "bits")))) + ((not accum-bits) + (set! accum-bits (+ -1 (integer-length generator))))) + (set! generator (logand generator (lognot (ash 1 accum-bits)))) + (cond ((>= (integer-length generator) accum-bits) + (slib:error 'make-port-crc + "generator longer than" 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))))) + (make-crc-table) + `(lambda (port) + (define crc 0) + (define byte-count 0) + (define crctab ',crctab) + (do ((ci (read-byte port) (read-byte port))) + ((eof-object? ci)) + ,(accum 'ci) + (set! byte-count (+ 1 byte-count))) + (do ((byte-count byte-count (ash byte-count ,(- chunk-bits)))) + ((zero? byte-count)) + ,(accum 'byte-count)) + (logxor ,(make-mask accum-bits) crc)))) diff --git a/module/slib/mbe.scm b/module/slib/mbe.scm new file mode 100644 index 000000000..df8885764 --- /dev/null +++ b/module/slib/mbe.scm @@ -0,0 +1,443 @@ +;;;; "mbe.scm" "Macro by Example" (Eugene Kohlbecker, R4RS) +;;; From: Dorai Sitaram, dorai@cs.rice.edu, 1991, 1999 +; +;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). +;;; corrections, Apr. 24, 1997. +;;; corr., Jan. 30, 1999. (mflatt@cs.rice.edu, dorai@cs.rice.edu) + +;;; A vanilla implementation of hygienic macro-by-example as described +;;; by Eugene Kohlbecker and in R4RS Appendix. 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) + +(define hyg:rassq + (lambda (k al) + (let loop ((al al)) + (if (null? al) #f + (let ((c (car al))) + (if (eq? (cdr c) k) c + (loop (cdr al)))))))) + +(define hyg:tag + (lambda (e kk al) + (cond ((pair? e) + (let* ((a-te-al (hyg:tag (car e) kk al)) + (d-te-al (hyg:tag (cdr e) kk (cdr a-te-al)))) + (cons (cons (car a-te-al) (car d-te-al)) + (cdr d-te-al)))) + ((vector? e) + (list->vector + (hyg:tag (vector->list e) kk al))) + ((symbol? e) + (cond ((eq? e '...) (cons '... al)) + ((memq e kk) (cons e al)) + ((hyg:rassq e al) => + (lambda (c) + (cons (car c) al))) + (else + (let ((te (gentemp))) + (cons te (cons (cons te e) al)))))) + (else (cons e al))))) + +;;untagging + +(define hyg:untag + (lambda (e al tmps) + (if (pair? e) + (let ((a (hyg:untag (car e) al tmps))) + (if (list? e) + (case a + ((quote) (hyg:untag-no-tags e al)) + ((quasiquote) (list a (hyg:untag-quasiquote (cadr e) al tmps))) + ((if begin) + `(,a ,@(map (lambda (e1) + (hyg:untag e1 al tmps)) (cdr e)))) + ((set! define) + `(,a ,(hyg:untag-vanilla (cadr e) al tmps) + ,@(map (lambda (e1) + (hyg:untag e1 al tmps)) (cddr e)))) + ((lambda) (hyg:untag-lambda (cadr e) (cddr e) al tmps)) + ((letrec) (hyg:untag-letrec (cadr e) (cddr e) al tmps)) + ((let) + (let ((e2 (cadr e))) + (if (symbol? e2) + (hyg:untag-named-let e2 (caddr e) (cdddr e) al tmps) + (hyg:untag-let e2 (cddr e) al tmps)))) + ((let*) (hyg:untag-let* (cadr e) (cddr e) al tmps)) + ((do) (hyg:untag-do (cadr e) (caddr e) (cdddr e) al tmps)) + ((case) + `(case ,(hyg:untag-vanilla (cadr e) al tmps) + ,@(map + (lambda (c) + `(,(hyg:untag-vanilla (car c) al tmps) + ,@(hyg:untag-list (cdr c) al tmps))) + (cddr e)))) + ((cond) + `(cond ,@(map + (lambda (c) + (hyg:untag-list c al tmps)) + (cdr e)))) + (else (cons a (hyg:untag-list (cdr e) al tmps)))) + (cons a (hyg:untag-list* (cdr e) al tmps)))) + (hyg:untag-vanilla e al tmps)))) + +(define hyg:untag-list + (lambda (ee al tmps) + (map (lambda (e) + (hyg:untag e al tmps)) ee))) + +(define hyg:untag-list* + (lambda (ee al tmps) + (let loop ((ee ee)) + (if (pair? ee) + (cons (hyg:untag (car ee) al tmps) + (loop (cdr ee))) + (hyg:untag ee al tmps))))) + +(define hyg:untag-no-tags + (lambda (e al) + (cond ((pair? e) + (cons (hyg:untag-no-tags (car e) al) + (hyg:untag-no-tags (cdr e) al))) + ((vector? e) + (list->vector + (hyg:untag-no-tags (vector->list e) al))) + ((not (symbol? e)) e) + ((assq e al) => cdr) + (else e)))) + +(define hyg:untag-quasiquote + (lambda (form al tmps) + (let qq ((x form) (level 0)) + (cond + ((pair? x) + (let ((first (qq (car x) level))) + (cond + ((and (eq? first 'unquote) (list? x)) + (let ((rest (cdr x))) + (if (or (not (pair? rest)) + (not (null? (cdr rest)))) + (slib:error 'unquote 'takes-exactly-one-expression) + (if (zero? level) + (list 'unquote (hyg:untag (car rest) al tmps)) + (cons first (qq rest (sub1 level))))))) + ((and (eq? first 'quasiquote) (list? x)) + (cons 'quasiquote (qq (cdr x) (add1 level)))) + ((and (eq? first 'unquote-splicing) (list? x)) + (slib:error 'unquote-splicing 'invalid-context-within-quasiquote)) + ((pair? first) + (let ((car-first (qq (car first) level))) + (if (and (eq? car-first 'unquote-splicing) + (list? first)) + (let ((rest (cdr first))) + (if (or (not (pair? rest)) + (not (null? (cdr rest)))) + (slib:error 'unquote-splicing + 'takes-exactly-one-expression) + (list (list 'unquote-splicing + (if (zero? level) + (hyg:untag (cadr rest) al tmps) + (qq (cadr rest) (sub1 level))) + (qq (cdr x) level))))) + (cons (cons car-first + (qq (cdr first) level)) + (qq (cdr x) level))))) + (else + (cons first (qq (cdr x) level)))))) + ((vector? x) + (list->vector + (qq (vector->list x) level))) + (else (hyg:untag-no-tags x al)))))) + +(define hyg:untag-lambda + (lambda (bvv body al tmps) + (let ((tmps2 (nconc (hyg:flatten bvv) tmps))) + `(lambda ,bvv + ,@(hyg:untag-list body al tmps2))))) + +(define hyg:untag-letrec + (lambda (varvals body al tmps) + (let ((tmps (nconc (map car varvals) tmps))) + `(letrec + ,(map + (lambda (varval) + `(,(car varval) + ,(hyg:untag (cadr varval) al tmps))) + varvals) + ,@(hyg:untag-list body al tmps))))) + +(define hyg:untag-let + (lambda (varvals body al tmps) + (let ((tmps2 (nconc (map car varvals) tmps))) + `(let + ,(map + (lambda (varval) + `(,(car varval) + ,(hyg:untag (cadr varval) al tmps))) + varvals) + ,@(hyg:untag-list body al tmps2))))) + +(define hyg:untag-named-let + (lambda (lname varvals body al tmps) + (let ((tmps2 (cons lname (nconc (map car varvals) tmps)))) + `(let ,lname + ,(map + (lambda (varval) + `(,(car varval) + ,(hyg:untag (cadr varval) al tmps))) + varvals) + ,@(hyg:untag-list body al tmps2))))) + +(define hyg:untag-let* + (lambda (varvals body al tmps) + (let ((tmps2 (nconc (nreverse (map car varvals)) tmps))) + `(let* + ,(let loop ((varvals varvals) + (i (length varvals))) + (if (null? varvals) '() + (let ((varval (car varvals))) + (cons `(,(car varval) + ,(hyg:untag (cadr varval) + al (list-tail tmps2 i))) + (loop (cdr varvals) (- i 1)))))) + ,@(hyg:untag-list body al tmps2))))) + +(define hyg:untag-do + (lambda (varinistps exit-test body al tmps) + (let ((tmps2 (nconc (map car varinistps) tmps))) + `(do + ,(map + (lambda (varinistp) + (let ((var (car varinistp))) + `(,var ,@(hyg:untag-list (cdr varinistp) al + (cons var tmps))))) + varinistps) + ,(hyg:untag-list exit-test al tmps2) + ,@(hyg:untag-list body al tmps2))))) + +(define hyg:untag-vanilla + (lambda (e al tmps) + (cond ((pair? e) + (cons (hyg:untag-vanilla (car e) al tmps) + (hyg:untag-vanilla (cdr e) al tmps))) + ((vector? e) + (list->vector + (hyg:untag-vanilla (vector->list e) al tmps))) + ((not (symbol? e)) e) + ((memq e tmps) e) + ((assq e al) => cdr) + (else 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)))))) + +;;;; 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))))))) + +;;; (mbe:append-map f l) == (apply append (map f l)) + +(define mbe:append-map + (lambda (f l) + (let loop ((l l)) + (if (null? l) '() + (append (f (car l)) (loop (cdr l))))))) + +;;; 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 (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) + (let ((sub-envs-list + (let loop ((r r) (sub-envs-list '())) + (if (null? r) (nreverse sub-envs-list) + (let ((c (car r))) + (loop (cdr r) + (if (mbe:contained-in? nestings (car c)) + (cons (cdr c) sub-envs-list) + sub-envs-list))))))) + (case (length sub-envs-list) + ((0) #f) + ((1) (car sub-envs-list)) + (else + (let loop ((sub-envs-list sub-envs-list) (final-sub-envs '())) + (if (some null? sub-envs-list) (nreverse final-sub-envs) + (loop (map cdr sub-envs-list) + (cons (mbe:append-map car sub-envs-list) + final-sub-envs))))))))) + +;;; 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) + (some (lambda (v_i) + (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) + (let ((tagged-out-pattern+alist + (hyg:tag + ',out-pattern + (nconc (hyg:flatten ',in-pattern) + keywords) '()))) + (hyg:untag + (mbe:expand-pattern + (car tagged-out-pattern+alist) + (mbe:get-bindings ',in-pattern macro-arg + keywords) + keywords) + (cdr tagged-out-pattern+alist) + '()))))) + 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/module/slib/minimize.scm b/module/slib/minimize.scm new file mode 100644 index 000000000..50a7e653e --- /dev/null +++ b/module/slib/minimize.scm @@ -0,0 +1,114 @@ +;;; "minimize.scm" finds minimum f(x) for x0 <= x <= x1. +;;; Author: Lars Arvestad +;;; +;;; This code is in the public domain. + +;;@noindent +;; +;;The Golden Section Search +;;@footnote{David Kahaner, Cleve Moler, and Stephen Nash +;;@cite{Numerical Methods and Software} +;;Prentice-Hall, 1989, ISBN 0-13-627258-4} +;;algorithm finds minima of functions which +;;are expensive to compute or for which derivatives are not available. +;;Although optimum for the general case, convergence is slow, +;;requiring nearly 100 iterations for the example (x^3-2x-5). +;; +;;@noindent +;; +;;If the derivative is available, Newton-Raphson is probably a better +;;choice. If the function is inexpensive to compute, consider +;;approximating the derivative. + +;;@body +;; +;;@var{x_0} are @var{x_1} real numbers. The (single argument) +;;procedure @var{f} is unimodal over the open interval (@var{x_0}, +;;@var{x_1}). That is, there is exactly one point in the interval for +;;which the derivative of @var{f} is zero. +;; +;;@0 returns a pair (@var{x} . @var{f}(@var{x})) where @var{f}(@var{x}) +;;is the minimum. The @var{prec} parameter is the stop criterion. If +;;@var{prec} is a positive number, then the iteration continues until +;;@var{x} is within @var{prec} from the true value. If @var{prec} is +;;a negative integer, then the procedure will iterate @var{-prec} +;;times or until convergence. If @var{prec} is a procedure of seven +;;arguments, @var{x0}, @var{x1}, @var{a}, @var{b}, @var{fa}, @var{fb}, +;;and @var{count}, then the iterations will stop when the procedure +;;returns @code{#t}. +;; +;;Analytically, the minimum of x^3-2x-5 is 0.816497. +;;@example +;;(define func (lambda (x) (+ (* x (+ (* x x) -2)) -5))) +;;(golden-section-search func 0 1 (/ 10000)) +;; ==> (816.4883855245578e-3 . -6.0886621077391165) +;;(golden-section-search func 0 1 -5) +;; ==> (819.6601125010515e-3 . -6.088637561916407) +;;(golden-section-search func 0 1 +;; (lambda (a b c d e f g ) (= g 500))) +;; ==> (816.4965933140557e-3 . -6.088662107903635) +;;@end example + +(define golden-section-search + (let ((gss 'golden-section-search:) + (r (/ (- (sqrt 5) 1) 2))) ; 1 / golden-section + (lambda (f x0 x1 prec) + (cond ((not (procedure? f)) (slib:error gss 'procedure? f)) + ((not (number? x0)) (slib:error gss 'number? x0)) + ((not (number? x1)) (slib:error gss 'number? x1)) + ((>= x0 x1) (slib:error gss x0 'not '< x1))) + (let ((stop? + (cond + ((procedure? prec) prec) + ((number? prec) + (if (>= prec 0) + (lambda (x0 x1 a b fa fb count) (<= (abs (- x1 x0)) prec)) + (if (integer? prec) + (lambda (x0 x1 a b fa fb count) (>= count (- prec))) + (slib:error gss 'integer? prec)))) + (else (slib:error gss 'procedure? prec)))) + (a0 (+ x0 (* (- x1 x0) (- 1 r)))) + (b0 (+ x0 (* (- x1 x0) r))) + (delta #f) + (fmax #f) + (fmin #f)) + (let loop ((left x0) + (right x1) + (a a0) + (b b0) + (fa (f a0)) + (fb (f b0)) + (count 1)) + (define finish + (lambda (x fx) + (if (> fx fmin) (slib:warn gss fx 'not 'min (list '> fmin))) + (if (and (> count 9) (or (eqv? x0 left) (eqv? x1 right))) + (slib:warn gss 'min 'not 'found)) + (cons x fx))) + (case count + ((1) + (set! fmax (max fa fb)) + (set! fmin (min fa fb))) + ((2) + (set! fmin (min fmin fa fb)) + (if (eqv? fmax fa fb) (slib:error gss 'flat? fmax))) + (else + (set! fmin (min fmin fa fb)))) + (cond ((stop? left right a b fa fb count) + (if (< fa fb) + (finish a fa) + (finish b fb))) + ((< fa fb) + (let ((a-next (+ left (* (- b left) (- 1 r))))) + (cond ((and delta (< delta (- b a))) + (finish a fa)) + (else (set! delta (- b a)) + (loop left b a-next a (f a-next) fa + (+ 1 count)))))) + (else + (let ((b-next (+ a (* (- right a) r)))) + (cond ((and delta (< delta (- b a))) + (finish b fb)) + (else (set! delta (- b a)) + (loop a right b b-next fb (f b-next) + (+ 1 count)))))))))))) diff --git a/module/slib/minimize.txi b/module/slib/minimize.txi new file mode 100644 index 000000000..785be35af --- /dev/null +++ b/module/slib/minimize.txi @@ -0,0 +1,48 @@ +@noindent + +The Golden Section Search +@footnote{David Kahaner, Cleve Moler, and Stephen Nash +@cite{Numerical Methods and Software} +Prentice-Hall, 1989, ISBN 0-13-627258-4} +algorithm finds minima of functions which +are expensive to compute or for which derivatives are not available. +Although optimum for the general case, convergence is slow, +requiring nearly 100 iterations for the example (x^3-2x-5). + +@noindent + +If the derivative is available, Newton-Raphson is probably a better +choice. If the function is inexpensive to compute, consider +approximating the derivative. + + +@defun golden-section-search f x0 x1 prec + + +@var{x_0} are @var{x_1} real numbers. The (single argument) +procedure @var{f} is unimodal over the open interval (@var{x_0}, +@var{x_1}). That is, there is exactly one point in the interval for +which the derivative of @var{f} is zero. + +@code{golden-section-search} returns a pair (@var{x} . @var{f}(@var{x})) where @var{f}(@var{x}) +is the minimum. The @var{prec} parameter is the stop criterion. If +@var{prec} is a positive number, then the iteration continues until +@var{x} is within @var{prec} from the true value. If @var{prec} is +a negative integer, then the procedure will iterate @var{-prec} +times or until convergence. If @var{prec} is a procedure of seven +arguments, @var{x0}, @var{x1}, @var{a}, @var{b}, @var{fa}, @var{fb}, +and @var{count}, then the iterations will stop when the procedure +returns @code{#t}. + +Analytically, the minimum of x^3-2x-5 is 0.816497. +@example +(define func (lambda (x) (+ (* x (+ (* x x) -2)) -5))) +(golden-section-search func 0 1 (/ 10000)) + ==> (816.4883855245578e-3 . -6.0886621077391165) +(golden-section-search func 0 1 -5) + ==> (819.6601125010515e-3 . -6.088637561916407) +(golden-section-search func 0 1 + (lambda (a b c d e f g ) (= g 500))) + ==> (816.4965933140557e-3 . -6.088662107903635) +@end example +@end defun diff --git a/module/slib/mitcomp.pat b/module/slib/mitcomp.pat new file mode 100644 index 000000000..78cb9b9e6 --- /dev/null +++ b/module/slib/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/module/slib/mitscheme.init b/module/slib/mitscheme.init new file mode 100644 index 000000000..c3c0c2dc2 --- /dev/null +++ b/module/slib/mitscheme.init @@ -0,0 +1,283 @@ +;;;"mitscheme.init" Initialization for SLIB for MITScheme -*-scheme-*- +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. + +;;; Make this part of your ~/.scheme.init file. + +(define getenv get-environment-variable) + +;;; (software-type) should be set to the generic operating system type. +(define (software-type) (if (getenv "HOMEDRIVE") 'MS-DOS 'UNIX)) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. + +(define (scheme-implementation-type) 'MITScheme) + +;;; (scheme-implementation-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) + "http://swissnet.ai.mit.edu/scheme-home.html") + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) + (let* ((str (with-output-to-string identify-world)) + (beg (+ (string-search-forward "Release " str) 8)) + (rst (substring str beg (string-length str))) + (end (string-find-next-char-in-set + rst + (predicate->char-set char-whitespace?)))) + (substring rst 0 end))) + +;;; (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) + ((MS-DOS) "c:\\scheme\\") + ((UNIX) "/usr/local/lib/mit-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) + ((MS-DOS) "c:\\slib\\") + ((UNIX) "/usr/local/lib/slib/") + ((VMS) "lib$scheme:") + (else ""))))) + (lambda () library-path))) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define home-vicinity + (let ((home-path (getenv "HOME"))) + (lambda () home-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 + 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 + defmacro + compiler + getenv + Xwindows + current-time + )) + +(define current-time current-file-time) +(define difftime -) +(define offset-time +) + +;;; (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) +(define object->limited-string write-to-string) + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. It is defined incorrectly (65536) +;;; by MITScheme version 8.0. +(define char-code-limit 256) + +;;; MOST-POSITIVE-FIXNUM is used in modular.scm +(define most-positive-fixnum #x03FFFFFF) + +;;; Return argument +(define (identity x) x) + +;;; 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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;; define an error procedure for the library +(define (slib:error . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (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) ".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.scm")) diff --git a/module/slib/mklibcat.scm b/module/slib/mklibcat.scm new file mode 100644 index 000000000..d7ec8dcb3 --- /dev/null +++ b/module/slib/mklibcat.scm @@ -0,0 +1,198 @@ +;"mklibcat.scm" Build catalog for SLIB +;Copyright (C) 1997 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. + +(call-with-output-file (in-vicinity (implementation-vicinity) "slibcat") + (lambda (op) + (display ";\"slibcat\" SLIB catalog for " op) + (display (scheme-implementation-type) op) + (display (scheme-implementation-version) op) + (display ". -*-scheme-*-" op) (newline op) + (display ";" op) (newline op) + (display "; DO NOT EDIT THIS FILE -- it is automagically generated" op) + (newline op) (newline op) + + (display "(" op) (newline op) + (for-each + (lambda (asp) (display " " op) (write asp op) (newline op)) + (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")) + (cons 'jfilter + (in-vicinity (sub-vicinity (library-vicinity) "jfilter") + "jfilter"))) + (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 defmacro . "fluidlet") + (alist . "alist") + (hash . "hash") + (sierpinski . "sierpinski") + (soundex . "soundex") + (hash-table . "hashtab") + (logical . "logical") + (random . "random") + (random-inexact . "randinex") + (modular . "modular") + (factor . "factor") + (primes . factor) + (charplot . "charplot") + (sort . "sort") + (tsort . topological-sort) + (topological-sort . "tsort") + (common-list-functions . "comlist") + (tree . "tree") + (coerce . "coerce") + (format . "format") + (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 . macro-by-example) + (object . "object") + (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 . "psxtime") + (common-lisp-time . "cltime") + (time-zone . "timezone") + (relational-database . "rdms") + (database-utilities . "dbutil") + (database-browse . "dbrowse") + (html-form . "htmlform") + (alist-table . "alistab") + (parameters . "paramlst") + (getopt-parameters . "getparam") + (read-command . "comparse") + (batch . "batch") + (glob . "glob") + (filename . glob) + (make-crc . "makcrc") + (fft . "fft") + (wt-tree . "wttree") + (string-search . "strsrch") + (root . "root") + (minimize . "minimize") + (precedence-parse . "prec") + (parse . precedence-parse) + (commutative-ring . "cring") + (self-set . "selfset") + (determinant . "determ") + (byte . "byte") + (tzfile . "tzfile") + (schmooz . "schmooz") + (net-clients . "nclients") + (db->html . "db2html") + (http . "http-cgi") + (cgi . http) + (uri . "uri") + (uniform-resource-identifier . uri) + (pnm . "pnm") + (metric-units . "simetrix") + (new-catalog . "mklibcat") + )))) + (display " " op) + + (let* ((req (in-vicinity (library-vicinity) + (string-append "require" (scheme-file-suffix))))) + (write (cons '*SLIB-VERSION* (or (require:version req) *SLIB-VERSION*)) + op)) + (newline op) + (display ")" op) (newline op) + + (let ((load-if-exists + (lambda (path) + (cond ((not (file-exists? path)) + (set! path (string-append path (scheme-file-suffix))))) + (cond ((file-exists? path) + (slib:load-source path)))))) + ;;(load-if-exists (in-vicinity (implementation-vicinity) "mksitcat")) + (load-if-exists (in-vicinity (implementation-vicinity) "mkimpcat"))) + + (let ((catcat + (lambda (vicinity name specificity) + (let ((path (in-vicinity vicinity name))) + (and (file-exists? path) + (call-with-input-file path + (lambda (ip) + (newline op) + (display "; " op) + (write path op) + (display " SLIB " op) + (display specificity op) + (display "-specific catalog additions" op) + (newline op) (newline op) + (do ((c (read-char ip) (read-char ip))) + ((eof-object? c)) + (write-char c op))))))))) + (catcat (library-vicinity) "sitecat" "site") + (catcat (implementation-vicinity) "implcat" "implementation") + (catcat (implementation-vicinity) "sitecat" "site")) + )) + +(set! *catalog* #f) diff --git a/module/slib/modular.scm b/module/slib/modular.scm new file mode 100644 index 000000000..357ce7710 --- /dev/null +++ b/module/slib/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/module/slib/mulapply.scm b/module/slib/mulapply.scm new file mode 100644 index 000000000..d696ee210 --- /dev/null +++ b/module/slib/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/module/slib/mularg.scm b/module/slib/mularg.scm new file mode 100644 index 000000000..a327b2bc5 --- /dev/null +++ b/module/slib/mularg.scm @@ -0,0 +1,12 @@ +;;; "mularg.scm" Redefine - and / to take more than 2 arguments. + +(define / /) +(define - -) +(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/module/slib/mwdenote.scm b/module/slib/mwdenote.scm new file mode 100644 index 000000000..def1d4db2 --- /dev/null +++ b/module/slib/mwdenote.scm @@ -0,0 +1,289 @@ +;"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)) + (case . (special case)) ;; @@ added wdc + (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-case + (mw:syntax-lookup mw:standard-syntax-environment 'case)) ;; @@ wdc + +(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. + +; @@ rewrote to strip *all* suffixes -- wdc + +(define mw:strip + (letrec ((original-symbol + (lambda (x) + (let ((s (symbol->string x))) + (loop x s 0 (string-length s))))) + (loop + (lambda (sym s i n) + (cond ((= i n) sym) + ((char=? (string-ref s i) + mw:suffix-character) + (string->symbol (substring s 0 i))) + (else + (loop sym s (+ i 1) n)))))) + (lambda (x) + (cond ((symbol? x) + (original-symbol x)) + ((pair? x) + (let ((y (mw:strip (car x))) + (z (mw:strip (cdr x)))) + (if (and (eq? y (car x)) + (eq? z (cdr x))) + x + (cons y z)))) + ((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/module/slib/mwexpand.scm b/module/slib/mwexpand.scm new file mode 100644 index 000000000..9dea34bb5 --- /dev/null +++ b/module/slib/mwexpand.scm @@ -0,0 +1,565 @@ +;"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)) + ; @@ case has a nontrivial syntax also -- wdc + ((eq? keyword mw:denote-of-case) (mw:case 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) +) + +; CASE -- added by wdc +(define (mw:case exp env) + (let ((expand (lambda (exp) + (mw:expand exp env)))) + (if (< (mw:safe-length exp) 3) + (mw:error "Malformed case expression" exp env) + `(case ,(expand (cadr exp)) + ,@(map (lambda (clause) + (if (< (mw:safe-length exp) 2) + (mw:error "Malformed case clause" exp env) + (cons (mw:strip (car clause)) + (map expand (cdr clause))))) + (cddr 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/module/slib/mwsynrul.scm b/module/slib/mwsynrul.scm new file mode 100644 index 000000000..bc5d7de20 --- /dev/null +++ b/module/slib/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/module/slib/nclients.scm b/module/slib/nclients.scm new file mode 100644 index 000000000..689de4728 --- /dev/null +++ b/module/slib/nclients.scm @@ -0,0 +1,385 @@ +;;; "nclients.scm" Interface to net-client programs. +; Copyright 1997, 1998 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-search) +(require 'line-i/o) +(require 'system) +(require 'printf) +(require 'scanf) + +;;@args proc +;;@args proc k +;;Calls @1 with @var{k} arguments, strings returned by successive +;;calls to @code{tmpnam}. If @1 returns, then any files named by the +;;arguments to @1 are deleted automatically and the value(s) yielded +;;by the @1 is(are) returned. @var{k} may be ommited, in which case +;;it defaults to @code{1}. +(define (call-with-tmpnam proc . k) + (do ((cnt (if (null? k) 0 (+ -1 (car k))) (+ -1 cnt)) + (paths '() (cons (tmpnam) paths))) + ((negative? cnt) + (let ((ans (apply proc paths))) + (for-each (lambda (path) (if (file-exists? path) (delete-file path))) + paths) + ans)))) + +;;@args +;;@0 returns a string of the form @samp{username@r{@@}hostname}. If +;;this e-mail address cannot be obtained, #f is returned. +(define user-email-address + (let ((user (or (getenv "USER") (getenv "USERNAME"))) + (hostname (getenv "HOSTNAME"))) ;with domain + (lambda () + (if (not (and user hostname)) + (call-with-tmpnam + (lambda (tmp) + (define command->string + (lambda (command) + (and (zero? (system (string-append command " >" tmp))) + (file-exists? tmp) + (let ((res #f)) + (call-with-input-file tmp + (lambda (port) + (and (eqv? 1 (fscanf port "%s" res)) res))))))) + (case (software-type) + ;;((AMIGA) ) + ;;((MACOS THINKC) ) + ((MS-DOS WINDOWS OS/2 ATARIST) + (let ((compname (getenv "COMPUTERNAME")) ;without domain + (workgroup #f) + (netdir (or (getenv "windir") + (getenv "winbootdir") + (and (getenv "SYSTEMROOT") + (string-append (getenv "SYSTEMROOT") + "\\system32")) + "C:\\windows"))) + (define (net . cmd) + (zero? (system (apply string-append + (or netdir "") + (if netdir "\\" "") + "NET " cmd)))) + (and (not (and user hostname)) + (zero? (system (string-append + (or netdir "") + (if netdir "\\" "") + "IPCONFIG /ALL > " tmp " "))) + (file-exists? tmp) + ;;(print tmp '=) (display-file tmp) + (call-with-input-file tmp + (lambda (port) + (find-string-from-port? "Host Name" port) + (fscanf port " %*[. ]: %s" hostname) + (delete-file tmp)))) + (and (not (and user hostname)) + (net "START /LIST >" tmp) + (file-exists? tmp) + (not (eof-object? (call-with-input-file tmp read-char))) + (cond + ((call-with-input-file tmp + (lambda (port) + (find-string-from-port? "o network servic" port))) + (and (net "CONFIG /YES >" tmp) + (net "STOP /YES"))) + (else (net "CONFIG /YES >" tmp))) + (call-with-input-file tmp + (lambda (port) + (do ((line (read-line port) (read-line port))) + ((eof-object? line)) + (sscanf line " Workstation root directory %s" + netdir) + (sscanf line " Computer name \\\\%s" compname) + (sscanf line " Workstation Domain %s" workgroup) + (sscanf line " Workgroup %s" workgroup) + (sscanf line " User name %s" user))))) + (and netdir (not (and user hostname)) + (set! netdir (string-append netdir "\\system.ini")) + (file-exists? netdir) + (call-with-input-file netdir + (lambda (port) + (and (find-string-from-port? "[DNS]" port) + (read-line port) ;past newline + (do ((line (read-line port) (read-line port))) + ((not (and (string? line) + (string-index line #\=)))) + (sscanf line "HostName=%s" compname) + (sscanf line "DomainName=%s" workgroup))))) + (not user) + (call-with-input-file netdir + (lambda (port) + (and (find-string-from-port? "[Network]" port) + (read-line port) ;past newline + (do ((line (read-line port) (read-line port))) + ((not (and (string? line) + (string-index line #\=)))) + (sscanf line "UserName=%s" user)))))) + (if (and compname (not hostname)) + (set! hostname + (string-append + compname "." (or workgroup "localnet")))))) + ;;((NOSVE) ) + ;;((VMS) ) + ((UNIX COHERENT) + (if (not user) + (set! user (command->string "whoami"))) + (if (not hostname) + (set! hostname (command->string "hostname"))))) + (if (not user) (set! user "John_Doe")) + (if (not hostname) (set! hostname "localhost"))))) + (string-append user "@" hostname)))) + +;;@args +;;@0 returns a string containing the absolute file name representing +;;the current working directory. If this string cannot be obtained, +;;#f is returned. +;; +;;If @0 cannot be supported by the platform, the value of @0 is +;;#f. +(define current-directory + (case (software-type) + ;;((AMIGA) ) + ;;((MACOS THINKC) ) + ((MS-DOS WINDOWS ATARIST OS/2) + (lambda () + (call-with-tmpnam + (lambda (tmp) + (and (zero? (system (string-append "cd >" tmp))) + (file-exists? tmp) + (call-with-input-file tmp + (lambda (port) + (let ((lst (scanf-read-list "%[^:]%[:] %s" port))) + (and (pair? lst) + (eqv? 3 (length lst)) + (apply string-append lst)))))))))) + ;;((NOSVE) ) + ((UNIX COHERENT) + (lambda () + (call-with-tmpnam + (lambda (tmp) + (and (zero? (system (string-append "pwd >" tmp))) + (file-exists? tmp) + (let ((path (call-with-input-file tmp read-line))) + (and (string? path) path))))))) + ;;((VMS) ) + (else #f))) + +;;@body +;;Creates a sub-directory @1 of the current-directory. If successful, +;;@0 returns #t; otherwise #f. +(define (make-directory name) + (zero? (system (string-append "mkdir " name)))) + +;;@body +;;Returns #t if changing directory to @1 makes the current working +;;directory the same as it is before changing directory; otherwise +;;returns #f. +(define (null-directory? file-name) + (member file-name '("" "." "./" ".\\"))) + +;;@body +;;Returns #t if @1 is a fully specified pathname (does not depend on +;;the current working directory); otherwise returns #f. +(define (absolute-path? file-name) + (and (string? file-name) + (positive? (string-length file-name)) + (memv (string-ref file-name 0) '(#\\ #\/)))) + + +;;@body Returns #t if the string @1 contains characters used for +;;specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}. +(define (glob-pattern? str) + (let loop ((idx (+ -1 (string-length str)))) + (if (negative? idx) + #f + (case (string-ref str idx) + ((#\* #\[ #\?) #t) + (else (loop (+ -1 idx))))))) + +;;@body +;;Returns a list of the decoded FTP @1; or #f if indecipherable. FTP +;;@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit} +;;formats are handled. The returned list has four elements which are +;;strings or #f: +;; +;;@enumerate 0 +;;@item +;;username +;;@item +;;password +;;@item +;;remote-site +;;@item +;;remote-directory +;;@end enumerate +(define (parse-ftp-address uri) + (define length? (lambda (len lst) (and (eqv? len (length lst)) lst))) + (cond + ((not uri) #f) + ((length? 1 (scanf-read-list " ftp://%s %s" uri)) + => (lambda (host) + (let ((login #f) (path #f) (dross #f)) + (sscanf (car host) "%[^/]/%[^@]%s" login path dross) + (and login + (append (cond + ((length? 2 (scanf-read-list "%[^@]@%[^@]%s" login)) + => (lambda (userpass@hostport) + (append + (cond ((length? 2 (scanf-read-list + "%[^:]:%[^@/]%s" + (car userpass@hostport)))) + (else (list (car userpass@hostport) #f))) + (cdr userpass@hostport)))) + (else (list "anonymous" #f login))) + (list path)))))) + (else + (let ((user@site #f) (colon #f) (path #f) (dross #f)) + (case (sscanf uri " %[^:]%[:]%[^@] %s" user@site colon path dross) + ((2 3) + (let ((user #f) (site #f)) + (cond ((or (eqv? 2 (sscanf user@site "/%[^@/]@%[^@]%s" + user site dross)) + (eqv? 2 (sscanf user@site "%[^@/]@%[^@]%s" + user site dross))) + (list user #f site path)) + ((eqv? 1 (sscanf user@site "@%[^@]%s" site dross)) + (list #f #f site path)) + (else (list #f #f user@site path))))) + (else + (let ((site (scanf-read-list " %[^@/] %s" uri))) + (and (length? 1 site) (list #f #f (car site) #f))))))))) + +;;@body +;;@3 must be a non-empty string or #f. @1 must be a non-empty list +;;of pathnames or Glob patterns (@pxref{Filenames}) matching files to +;;transfer. +;; +;;@0 puts the files specified by @1 into the @5 directory of FTP @4 +;;using name @2 with (optional) @3. +;; +;;If @3 is #f and @2 is not @samp{ftp} or @samp{anonymous}, then @2 is +;;ignored; FTP takes the username and password from the @file{.netrc} +;;or equivalent file. +(define (ftp-upload paths user password remote-site remote-dir) + (call-with-tmpnam + (lambda (script logfile) + (define local-path (current-directory)) + (define passwd (or password (user-email-address))) + (dynamic-wind + (lambda () #f) + (lambda () + (call-with-current-continuation + (lambda (exit) + (define (run-ftp-script paths) + (call-with-output-file script + (lambda (port) + (define lcd "") + (cond ((or (member user '(ftp anonymous "ftp" "anonymous")) + password) + (fprintf port "user %s %s\n" user passwd))) + (fprintf port "binary\n") ; Turn binary ON for all transfers + ;;(fprintf port "prompt\n") ; Turn prompt OFF for possible mget + (if (not (null-directory? remote-dir)) + (fprintf port "cd %s\n" remote-dir)) + (for-each + (lambda (path-name) + (let* ((r/i (string-reverse-index path-name #\/)) + (dir (if r/i (substring path-name 0 (+ 1 r/i)) "")) + (file-name (if r/i + (substring path-name (+ 1 r/i) + (string-length path-name)) + path-name))) + (cond ((and r/i (glob-pattern? dir)) + (slib:warn + "Wildcard not allowed in directory component " + path-name) + (exit #f)) + ((and (not (glob-pattern? file-name)) + (not (file-exists? path-name))) + (slib:warn " file doesn't exist:" path-name) + (exit #f)) + ((equal? lcd dir)) + ((absolute-path? dir) + (fprintf port "lcd %s\n" dir)) + ((eqv? 0 (substring? lcd dir)) + (fprintf port "lcd %s\n" + (substring dir (string-length lcd) + (string-length dir)))) + (else + (fprintf port "lcd %s\n" local-path) + (if (not (null-directory? dir)) + (fprintf port "lcd %s\n" dir)))) + (set! lcd dir) + (cond ((glob-pattern? file-name) + (fprintf port "mput %s\n" file-name)) + (else + (fprintf port "put %s\n" file-name))))) + paths))) + ;;(display-file script) + (cond + ((zero? (system + (string-append + "ftp " + (if (or (member user '(ftp anonymous "ftp" "anonymous")) + password) + "-inv" "-iv") + " " remote-site + " <" script + " >" logfile))) + (file-exists? logfile) + (call-with-input-file logfile + (lambda (port) + (do ((line (read-line port) (read-line port))) + ((or (eof-object? line) + (substring-ci? "Unknown host" line) + (substring-ci? "Not connected" line) + (and (memv (string-ref line 0) '(#\4 #\5)) + (not (substring-ci? "bytes" line)))) + (cond ((eof-object? line) #t) + (else (slib:warn line) #f))) + ;;(write-line line) + )))) + (else (slib:warn 'ftp 'failed) #f))) + (cond ((or local-path (every? absolute-file? paths)) + (run-ftp-script paths)) + (else (for-each (lambda (path) (run-ftp-script (list path))) + paths)))))) + (lambda () + (if (file-exists? script) (delete-file script)) + (if (file-exists? logfile) (delete-file logfile))))) + 2)) + +;;@body +;;Returns a URI-string for @1 on the local host. +(define (path->uri path) + (if (absolute-path? path) + (sprintf #f "file:%s" path) + (sprintf #f "file:%s/%s" (current-directory) path))) + +;;@body +;;If a @samp{netscape} browser is running, @0 causes the browser to +;;display the page specified by string @1 and returns #t. +;; +;;If the browser is not running, @0 runs @samp{netscape} with the +;;argument @1. If the browser starts as a background job, @0 returns +;;#t immediately; if the browser starts as a foreground job, then @0 +;;returns #t when the browser exits; otherwise it returns #f. +(define (browse-url-netscape url) + (or (eqv? 0 (system (sprintf #f "netscape-remote -remote 'openURL(%s)'" url))) + (eqv? 0 (system (sprintf #f "netscape -remote 'openURL(%s)'" url))) + (eqv? 0 (system (sprintf #f "netscape '%s'&" url))) + (eqv? 0 (system (sprintf #f "netscape '%s'" url))))) diff --git a/module/slib/nclients.txi b/module/slib/nclients.txi new file mode 100644 index 000000000..ff62436fe --- /dev/null +++ b/module/slib/nclients.txi @@ -0,0 +1,103 @@ + +@defun call-with-tmpnam proc + + +@defunx call-with-tmpnam proc k +Calls @var{proc} with @var{k} arguments, strings returned by successive +calls to @code{tmpnam}. If @var{proc} returns, then any files named by the +arguments to @var{proc} are deleted automatically and the value(s) yielded +by the @var{proc} is(are) returned. @var{k} may be ommited, in which case +it defaults to @code{1}. +@end defun + +@defun user-email-address + +@code{user-email-address} returns a string of the form @samp{username@r{@@}hostname}. If +this e-mail address cannot be obtained, #f is returned. +@end defun + +@defun current-directory + +@code{current-directory} returns a string containing the absolute file name representing +the current working directory. If this string cannot be obtained, +#f is returned. + +If @code{current-directory} cannot be supported by the platform, the value of @code{current-directory} is +#f. +@end defun + +@defun make-directory name + +Creates a sub-directory @var{name} of the current-directory. If successful, +@code{make-directory} returns #t; otherwise #f. +@end defun + +@defun null-directory? file-name + +Returns #t if changing directory to @var{file-name} makes the current working +directory the same as it is before changing directory; otherwise +returns #f. +@end defun + +@defun absolute-path? file-name + +Returns #t if @var{file-name} is a fully specified pathname (does not depend on +the current working directory); otherwise returns #f. +@end defun + +@defun glob-pattern? str +Returns #t if the string @var{str} contains characters used for +specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}. +@end defun + +@defun parse-ftp-address uri + +Returns a list of the decoded FTP @var{uri}; or #f if indecipherable. FTP +@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit} +@cindex Uniform Resource Locator +@cindex ange-ftp +@cindex getit +formats are handled. The returned list has four elements which are +strings or #f: + +@enumerate 0 +@item +username +@item +password +@item +remote-site +@item +remote-directory +@end enumerate +@end defun + +@defun ftp-upload paths user password remote-site remote-dir + +@var{password} must be a non-empty string or #f. @var{paths} must be a non-empty list +of pathnames or Glob patterns (@pxref{Filenames}) matching files to +transfer. + +@code{ftp-upload} puts the files specified by @var{paths} into the @var{remote-dir} directory of FTP @var{remote-site} +using name @var{user} with (optional) @var{password}. + +If @var{password} is #f and @var{user} is not @samp{ftp} or @samp{anonymous}, then @var{user} is +ignored; FTP takes the username and password from the @file{.netrc} +or equivalent file. +@end defun + +@defun path->uri path + +Returns a URI-string for @var{path} on the local host. +@end defun + +@defun browse-url-netscape url + +If a @samp{netscape} browser is running, @code{browse-url-netscape} causes the browser to +display the page specified by string @var{url} and returns #t. + +If the browser is not running, @code{browse-url-netscape} runs @samp{netscape} with the +argument @var{url}. If the browser starts as a background job, @code{browse-url-netscape} returns +#t immediately; if the browser starts as a foreground job, then @code{browse-url-netscape} +returns #t when the browser exits; otherwise it returns #f. +@end defun diff --git a/module/slib/obj2str.scm b/module/slib/obj2str.scm new file mode 100644 index 000000000..aa90bdef3 --- /dev/null +++ b/module/slib/obj2str.scm @@ -0,0 +1,63 @@ +;;; "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) + +;;@body Returns the textual representation of @1 as a string. +(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'. + +;;@body Returns the textual representation of @1 as a string of length +;;at most @2. +(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))) + (cond ((> len left) + (set! result (cons (substring str 0 left) result)) + (set! left 0) + #f) + (else + (set! result (cons str result)) + (set! left (- left len)) + #t))))) + (reverse-string-append result))) diff --git a/module/slib/obj2str.txi b/module/slib/obj2str.txi new file mode 100644 index 000000000..83e8b1b74 --- /dev/null +++ b/module/slib/obj2str.txi @@ -0,0 +1,9 @@ + +@defun object->string obj +Returns the textual representation of @var{obj} as a string. +@end defun + +@defun object->limited-string obj limit +Returns the textual representation of @var{obj} as a string of length +at most @var{limit}. +@end defun diff --git a/module/slib/objdoc.txi b/module/slib/objdoc.txi new file mode 100644 index 000000000..123417b69 --- /dev/null +++ b/module/slib/objdoc.txi @@ -0,0 +1,238 @@ + +@code{(require 'object)} +@ftindex 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) +@ftindex 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) +@ftindex 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) + (let* ((self (make-object + (make-number 1) + (make-description "A number which can be inverted"))) + (<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 (x) (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 diff --git a/module/slib/object.scm b/module/slib/object.scm new file mode 100644 index 000000000..c272ef928 --- /dev/null +++ b/module/slib/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/module/slib/paramlst.scm b/module/slib/paramlst.scm new file mode 100644 index 000000000..41ddfed70 --- /dev/null +++ b/module/slib/paramlst.scm @@ -0,0 +1,141 @@ +;;; "paramlst.scm" passing parameters by name. +; Copyright 1995, 1996, 1997, 2001 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 defaulters parameter-list) + (map (lambda (defaulter parameter) + (cond ((null? (cdr parameter)) + (cons (car parameter) + (if defaulter (defaulter parameter-list) '()))) + (else parameter))) + defaulters parameter-list)) + +(define (check-parameters checks parameter-list) + (and (every (lambda (check parameter) + (every + (lambda (p) + (let ((good? (not (and check (not (check p)))))) + (if (not good?) (slib:warn (car parameter) 'parameter? p)) + good?)) + (cdr parameter))) + checks parameter-list) + parameter-list)) + +(define (check-arities arity-specs parameter-list) + (every (lambda (arity-spec param) + (cond ((not arity-spec) (slib:warn 'missing 'arity arity-specs) #f) + (((cadr arity-spec) (cdr param)) #t) + ((null? (cdr param)) (slib:warn param 'missing) #f) + (else (slib:warn param 'not (car arity-spec)) #f))) + 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 (remove-parameter pname parameter-list) + (define found? #f) + (remove-if (lambda (elt) + (cond ((not (and (pair? elt) (eqv? pname (car elt)))) #f) + (found? + (slib:error + 'remove-parameter 'multiple pname 'in parameter-list)) + (else (set! found? #t) #t))) + parameter-list)) diff --git a/module/slib/plottest.scm b/module/slib/plottest.scm new file mode 100644 index 000000000..20734f4e7 --- /dev/null +++ b/module/slib/plottest.scm @@ -0,0 +1,47 @@ +;"plottest.scm" test charplot.scm +;Copyright (C) 1992 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'charplot) +(require 'random) + +(define strophoid + (let ((l '())) + (do ((x -1.0 (+ x 0.05))) + ((> x 4.0)) + (let* ((a (/ (- 2 x) (+ 2 x)))) + (if (>= a 0.0) + (let* ((y (* x (sqrt a)))) + (set! l (cons (cons x y) l)) + (set! l (cons (cons x (- y)) l)))))) + l)) + +(plot! strophoid "x" "y") (newline) + +(define unif + (let* ((l 6) + (v (make-vector l))) + (do ((i (- l 1) (- i 1))) + ((negative? i)) + (vector-set! v i (cons i 0))) + (do ((i 24 (- i 1)) + (r (random l) (random l))) + ((zero? i) (vector->list v)) + (set-cdr! (vector-ref v r) (+ 1 (cdr (vector-ref v r))))))) + +(plot! unif "n" "occur") diff --git a/module/slib/pnm.scm b/module/slib/pnm.scm new file mode 100644 index 000000000..daba19dc4 --- /dev/null +++ b/module/slib/pnm.scm @@ -0,0 +1,213 @@ +;;; "pnm.scm" Read PNM image files. +; Copyright 2000 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 'scanf) +(require 'printf) +(require 'array) +(require 'array-for-each) +(require 'byte) +(require 'line-i/o) + +(define (pnm:read+integer port) + (define uint #f) + (do ((chr (peek-char port) (peek-char port))) + ((not (and (char? chr) (or (char-whitespace? chr) (eqv? #\# chr))))) + (if (eqv? #\# chr) + (read-line port) + (read-char port))) + (if (eof-object? (peek-char port)) + (peek-char port) + (and (eqv? 1 (fscanf port " %u" uint)) uint))) + +(define (pnm:type-dimensions port) + (if (input-port? port) + (let* ((c1 (read-char port)) + (c2 (read-char port))) + (cond + ((and (eqv? #\P c1) + (char? c2) + (char-numeric? c2) + (char-whitespace? (peek-char port))) + (let* ((format (string->symbol (string #\p c2))) + (width (pnm:read+integer port)) + (height (pnm:read+integer port)) + (ret + (case format + ((p1) (list 'pbm width height 1)) + ((p4) (list 'pbm-raw width height 1)) + ((p2) (list 'pgm width height (pnm:read+integer port))) + ((p5) (list 'pgm-raw width height (pnm:read+integer port))) + ((p3) (list 'ppm width height (pnm:read+integer port))) + ((p6) (list 'ppm-raw width height (pnm:read+integer port))) + (else #f)))) + (and (char-whitespace? (read-char port)) ret))) + (else #f))) + (call-with-input-file port pnm:type-dimensions))) + +(define (pnm:read-binary! array port) + (array-map! array (lambda () (read-byte port)))) + +(define (pnm:image-file->array path . array) + (set! array (and (not (null? array)) (car array))) + (call-with-input-file path + (lambda (port) + (apply (lambda (type width height max-pixel) + (define (read-binary) + (pnm:read-binary! array port) + (if (eof-object? (peek-char port)) array + (slib:error type 'not 'at 'file 'end))) + (define (read-text) + (array-map! array (lambda () (pnm:read+integer port))) + (if (eof-object? (pnm:read+integer port)) array + (slib:error type 'not 'at 'file 'end))) + (define (read-pbm) + (array-map! array (lambda () (eqv? 1 (pnm:read+integer port)))) + (if (eof-object? (pnm:read+integer port)) array + (slib:error type 'not 'at 'file 'end))) + (case type + ((pbm) + (or array + (set! array (make-array #t height width))) + (read-pbm)) + ((pgm) + (or array + (set! array (make-array max-pixel height width))) + (read-text)) + ((ppm) + (or array + (set! array (make-array max-pixel height width 3))) + (read-text)) + ((pbm-raw) + (or array + (set! array (make-array #t height (quotient width 8)))) + (read-binary)) + ((pgm-raw) + (or array + (set! array (make-array max-pixel height width))) + (read-binary)) + ((ppm-raw) + (or array + (set! array (make-array max-pixel height width 3))) + (read-binary)))) + (pnm:type-dimensions port))))) + +(define (pnm:image-file->uniform-array path . array) + (fluid-let ((make-array make-uniform-array) + (pnm:read-binary! + (lambda (ra port) + (if (array? ra #t) + (error 'pnm:image-file->array + "pbm-raw support unimplemented") + (let ((bytes (apply make-uniform-array #\a + (array-dimensions ra)))) + (uniform-array-read! bytes port) + (array-map! ra char->integer bytes)))))) + (apply pnm:image-file->array path array))) + +;; ARRAY is required to be zero-based. +(define (pnm:array-write type array maxval port) + (define (write-header type height width maxval) + (let ((magic + (case type + ((pbm) "P1") + ((pgm) "P2") + ((ppm) "P3") + ((pbm-raw) "P4") + ((pgm-raw) "P5") + ((ppm-raw) "P6") + (else (error 'pnm:array-write "bad type" type))))) + (fprintf port "%s\n%d %d" magic width height) + (if maxval (fprintf port "\n%d" maxval)))) + (define (write-pixels type array maxval) + (let* ((shp (array-dimensions array)) + (height (car shp)) + (width (cadr shp))) + (case type + ((pbm-raw) + (newline port) + (if (array? array #t) + (uniform-array-write array port) + (error 'pnm:array-write "expected bit-array" array))) + ((pgm-raw ppm-raw) + (newline port) +;;; (let ((bytes (apply make-uniform-array #\a shp))) +;;; (array-map! bytes integer->char array) +;;; (uniform-array-write bytes port)) + (uniform-array-write array port)) + ((pbm) + (do ((i 0 (+ i 1))) + ((>= i height)) + (do ((j 0 (+ j 1))) + ((>= j width)) + (display (if (zero? (remainder j 35)) #\newline #\space) port) + (display (if (array-ref array i j) #\1 #\0) port))) + (newline port)) + ((pgm) + (do ((i 0 (+ i 1))) + ((>= i height)) + (do ((j 0 (+ j 1))) + ((>= j width)) + (display (if (zero? (remainder j 17)) #\newline #\space) port) + (display (array-ref array i j) port))) + (newline port)) + ((ppm) + (do ((i 0 (+ i 1))) + ((>= i height)) + (do ((j 0 (+ j 1))) + ((>= j width)) + (display (if (zero? (remainder j 5)) #\newline " ") port) + (display (array-ref array i j 0) port) + (display #\space port) + (display (array-ref array i j 1) port) + (display #\space port) + (display (array-ref array i j 2) port))) + (newline port))))) + + (if (output-port? port) + (let ((rnk (array-rank array)) + (shp (array-dimensions array))) + (case type + ((pbm pbm-raw) + (or (and (eqv? 2 rnk) + (integer? (car shp)) + (integer? (cadr shp))) + (error 'pnm:array-write "bad shape" type array)) + (or (eqv? 1 maxval) + (error 'pnm:array-write "maxval supplied not 1" type)) + (write-header type (car shp) (cadr shp) #f) + (write-pixels type array 1)) + ((pgm pgm-raw) + (or (and (eqv? 2 rnk) + (integer? (car shp)) + (integer? (cadr shp))) + (error 'pnm:array-write "bad shape" type array)) + (write-header type (car shp) (cadr shp) maxval) + (write-pixels type array maxval)) + ((ppm ppm-raw) + (or (and (eqv? 3 rnk) + (integer? (car shp)) + (integer? (cadr shp)) + (eqv? 3 (caddr shp))) + (error 'pnm:array-write "bad shape" type array)) + (write-header type (car shp) (cadr shp) maxval) + (write-pixels type array maxval)) + (else (error 'pnm:array-write type 'unrecognized 'type)))) + (call-with-output-file port + (lambda (port) + (pnm:array-write type array maxval port))))) diff --git a/module/slib/pp.scm b/module/slib/pp.scm new file mode 100644 index 000000000..feb90a8e0 --- /dev/null +++ b/module/slib/pp.scm @@ -0,0 +1,15 @@ +;"pp.scm" Pretty-Print +(require 'generic-write) + +(define (pp:pretty-print obj . opt) + (let ((port (if (pair? opt) (car opt) (current-output-port)))) + (generic-write obj #f (output-port-width port) + (lambda (s) (display s port) #t)))) + +(define (pretty-print->string obj . width) + (define result '()) + (generic-write obj #f (if (null? width) (output-port-width) (car width)) + (lambda (str) (set! result (cons str result)) #t)) + (reverse-string-append result)) + +(define pretty-print pp:pretty-print) diff --git a/module/slib/ppfile.scm b/module/slib/ppfile.scm new file mode 100644 index 000000000..4b21b6eec --- /dev/null +++ b/module/slib/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/module/slib/prec.scm b/module/slib/prec.scm new file mode 100644 index 000000000..f2f758207 --- /dev/null +++ b/module/slib/prec.scm @@ -0,0 +1,448 @@ +; "prec.scm", dynamically extensible parser/tokenizer -*-scheme-*- +; Copyright 1989, 1990, 1991, 1992, 1993, 1995, 1997 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 implements: +; * a Pratt style parser. +; * a tokenizer which congeals tokens according to assigned classes of +; constituent characters. +; +; This module is a significant improvement because grammar can be +; changed dynamically from rulesets which don't need compilation. +; Theoretically, all possibilities of bad input are handled and return +; as much structure as was parsed when the error occured; The symbol +; `?' is substituted for missing input. + +; References for the parser are: + +; Pratt, V. R. +; Top Down Operator Precendence. +; SIGACT/SIGPLAN +; Symposium on Principles of Programming Languages, +; Boston, 1973, 41-51 + +; WORKING PAPER 121 +; CGOL - an Alternative External Representation For LISP users +; Vaughan R. Pratt +; MIT Artificial Intelligence Lab. +; March 1976 + +; Mathlab Group, +; MACSYMA Reference Manual, Version Ten, +; Laboratory for Computer Science, MIT, 1983 + +(require 'fluid-let) +(require 'string-search) +(require 'string-port) +(require 'delay) + +(define *syn-defs* #f) +(define *syn-rules* #f) ;Dynamically bound +(define *prec:port* #f) ;Dynamically bound + +;; keeps track of input column so we can generate useful error displays. +(define tok:column 0) +(define (tok:peek-char) (peek-char *prec:port*)) +(define (tok:read-char) + (let ((c (read-char *prec:port*))) + (if (or (eqv? c #\newline) (eof-object? c)) + (set! tok:column 0) + (set! tok:column (+ 1 tok:column))) + c)) +(define (tok:bump-column pos . ports) + ((lambda (thunk) + (cond ((null? ports) (thunk)) + (else (fluid-let ((*prec:port* (car ports))) (thunk))))) + (lambda () + (cond ((eqv? #\newline (tok:peek-char)) + (tok:read-char))) ;to do newline + (set! tok:column (+ tok:column pos))))) +(define (prec:warn . msgs) + (do ((j (+ -1 tok:column) (+ -8 j))) + ((> 8 j) + (do ((i j (+ -1 i))) + ((>= 0 i)) + (display #\ ))) + (display slib:tab)) + (display "^ ") + (newline) + (for-each (lambda (x) (write x) (display #\ )) msgs) + (newline)) + +;; Structure of lexical records. +(define tok:make-rec cons) +(define tok:cc car) +(define tok:sfp cdr) + +(define (tok:lookup alist char) + (if (eof-object? char) + #f + (let ((pair (assv char alist))) + (and pair (cdr pair))))) + +(define (tok:char-group group chars chars-proc) + (map (lambda (token) +;;; (let ((oldlexrec (tok:lookup *syn-defs* token))) +;;; (cond ((or (not oldlexrec) (eqv? (tok:cc oldlexrec) group))) +;;; (else (math:warn 'cc-of token 'redefined-to- group)))) + (cons token (tok:make-rec group chars-proc))) + (cond ((string? chars) (string->list chars)) + ((char? chars) (list chars)) + (else chars)))) + +(define (tokenize) + (let* ((char (tok:read-char)) + (rec (tok:lookup *syn-rules* char)) + (proc (and rec (tok:cc rec))) + (clist (list char))) + (cond + ((not proc) char) + ((procedure? proc) + (do ((cl clist (begin (set-cdr! cl (list (tok:read-char))) (cdr cl)))) + ((proc (tok:peek-char)) + ((or (tok:sfp rec) list->string) clist)))) + ((eqv? 0 proc) (tokenize)) + (else + (do ((cl clist (begin (set-cdr! cl (list (tok:read-char))) (cdr cl)))) + ((not (let* ((prec (tok:lookup *syn-rules* (tok:peek-char))) + (cclass (and prec (tok:cc prec)))) + (or (eqv? cclass proc) + (eqv? cclass (+ -1 proc))))) + ((tok:sfp rec) clist))))))) + +;;; PREC:NUD is the null denotation (function and arguments to call when no +;;; unclaimed tokens). +;;; PREC:LED is the left denotation (function and arguments to call when +;;; unclaimed token is on left). +;;; PREC:LBP is the left binding power of this LED. It is the first +;;; argument position of PREC:LED + +(define (prec:nudf alist self) + (let ((pair (assoc (cons 'nud self) alist))) + (and pair (cdr pair)))) +(define (prec:ledf alist self) + (let ((pair (assoc (cons 'led self) alist))) + (and pair (cdr pair)))) +(define (prec:lbp alist self) + (let ((pair (assoc (cons 'led self) alist))) + (and pair (cadr pair)))) + +(define (prec:call-or-list proc . args) + (prec:apply-or-cons proc args)) +(define (prec:apply-or-cons proc args) + (if (procedure? proc) (apply proc args) (cons (or proc '?) args))) + +;;; PREC:SYMBOLFY and PREC:DE-SYMBOLFY are not exact inverses. +(define (prec:symbolfy obj) + (cond ((symbol? obj) obj) + ((string? obj) (string->symbol obj)) + ((char? obj) (string->symbol (string obj))) + (else obj))) + +(define (prec:de-symbolfy obj) + (cond ((symbol? obj) (symbol->string obj)) + (else obj))) + +;;;Calls to set up tables. + +(define (prec:define-grammar . synlsts) + (set! *syn-defs* (append (apply append synlsts) *syn-defs*))) + +(define (prec:make-led toks . args) + (map (lambda (tok) + (cons (cons 'led (prec:de-symbolfy tok)) + args)) + (if (pair? toks) toks (list toks)))) +(define (prec:make-nud toks . args) + (map (lambda (tok) + (cons (cons 'nud (prec:de-symbolfy tok)) + args)) + (if (pair? toks) toks (list toks)))) + +;;; Produce dynamically augmented grammars. +(define (prec:process-binds binds rules) + (if (and #f (not (null? binds)) (eq? #t (car binds))) + (cdr binds) + (append binds rules))) + +;;(define (prec:replace-rules) some-sort-of-magic-cookie) + +;;; Here are the procedures to define high-level grammar, along with +;;; utility functions called during parsing. The utility functions +;;; (prec:parse-*) could be incorportated into the defining commands, +;;; but tracing these functions is useful for debugging. + +(define (prec:delim tk) + (prec:make-led tk 0 #f)) + +(define (prec:nofix tk sop . binds) + (prec:make-nud tk prec:parse-nofix sop (apply append binds))) +(define (prec:parse-nofix self sop binds) + (set! *syn-rules* (prec:process-binds binds *syn-rules*)) + (prec:call-or-list (or sop (prec:symbolfy self)))) + +(define (prec:prefix tk sop bp . binds) + (prec:make-nud tk prec:parse-prefix sop bp (apply append binds))) +(define (prec:parse-prefix self sop bp binds) + (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) + (prec:call-or-list (or sop (prec:symbolfy self)) (prec:parse1 bp)))) + +(define (prec:infix tk sop lbp bp . binds) + (prec:make-led tk lbp prec:parse-infix sop bp (apply append binds))) +(define (prec:parse-infix left self lbp sop bp binds) + (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) + (prec:call-or-list (or sop (prec:symbolfy self)) left (prec:parse1 bp)))) + +(define (prec:nary tk sop bp) + (prec:make-led tk bp prec:parse-nary sop bp)) +(define (prec:parse-nary left self lbp sop bp) + (prec:apply-or-cons (or sop (prec:symbolfy self)) + (cons left (prec:parse-list self bp)))) + +(define (prec:postfix tk sop lbp . binds) + (prec:make-led tk lbp prec:parse-postfix sop (apply append binds))) +(define (prec:parse-postfix left self lbp sop binds) + (set! *syn-rules* (prec:process-binds binds *syn-rules*)) + (prec:call-or-list (or sop (prec:symbolfy self)) left)) + +(define (prec:prestfix tk sop bp . binds) + (prec:make-nud tk prec:parse-rest sop bp (apply append binds))) +(define (prec:parse-rest self sop bp binds) + (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) + (prec:apply-or-cons (or sop (prec:symbolfy self)) (prec:parse-list #f bp)))) + +(define (prec:commentfix tk stp match . binds) + (append + (prec:make-nud tk prec:parse-nudcomment stp match (apply append binds)) + (prec:make-led tk 220 prec:parse-ledcomment stp match (apply append binds)))) +(define (prec:parse-nudcomment self stp match binds) + (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) + (tok:read-through-comment stp match) + (prec:advance) + (cond ((prec:delim? (force prec:token)) #f) + (else (prec:parse1 prec:bp))))) +(define (prec:parse-ledcomment left lbp self stp match binds) + (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) + (tok:read-through-comment stp match) + (prec:advance) + left)) +(define (tok:read-through-comment stp match) + (set! match (if (char? match) + (string match) + (prec:de-symbolfy match))) + (cond ((procedure? stp) + (let* ((len #f) + (str (call-with-output-string + (lambda (sp) + (set! len (find-string-from-port? + match *prec:port* + (lambda (c) (display c sp) #f))))))) + (stp (and len (substring str 0 (- len (string-length match))))))) + (else (find-string-from-port? match *prec:port*)))) + +(define (prec:matchfix tk sop sep match . binds) + (define sep-lbp 0) + (prec:make-nud tk prec:parse-matchfix + sop sep-lbp sep match + (apply append (prec:delim match) binds))) +(define (prec:parse-matchfix self sop sep-lbp sep match binds) + (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) + (cond (sop (prec:apply-or-cons + sop (prec:parse-delimited sep sep-lbp match))) + ((equal? (force prec:token) match) + (prec:warn 'expression-missing) + (prec:advance) + '?) + (else (let ((ans (prec:parse1 0))) ;just parenthesized expression + (cond ((equal? (force prec:token) match) + (prec:advance)) + ((prec:delim? (force prec:token)) + (prec:warn 'mismatched-delimiter (force prec:token) + 'not match) + (prec:advance)) + (else (prec:warn 'delimiter-expected--ignoring-rest + (force prec:token) 'expected match + 'or-delimiter) + (do () ((prec:delim? (force prec:token))) + (prec:parse1 0)))) + ans))))) + +(define (prec:inmatchfix tk sop sep match lbp . binds) + (define sep-lbp 0) + (prec:make-led tk lbp prec:parse-inmatchfix + sop sep-lbp sep match + (apply append (prec:delim match) binds))) +(define (prec:parse-inmatchfix left self lbp sop sep-lbp sep match binds) + (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) + (prec:apply-or-cons + sop (cons left (prec:parse-delimited sep sep-lbp match))))) + +;;;; Here is the code which actually parses. + +(define prec:bp #f) ;dynamically bound +(define prec:token #f) +(define (prec:advance) + (set! prec:token (delay (tokenize)))) +(define (prec:advance-return-last) + (let ((last (and prec:token (force prec:token)))) + (prec:advance) + last)) + +(define (prec:nudcall self) + (let ((pob (prec:nudf *syn-rules* self))) + (cond + (pob (let ((proc (car pob))) + (cond ((procedure? proc) (apply proc self (cdr pob))) + (proc (cons proc (cdr pob))) + (else '?)))) + ((char? self) (prec:warn 'extra-separator) + (prec:advance) + (prec:nudcall (force prec:token))) + ((string? self) (string->symbol self)) + (else self)))) + +(define (prec:ledcall left self) + (let* ((pob (prec:ledf *syn-rules* self))) + (apply (cadr pob) left self (cdr pob)))) + +;;; PREC:PARSE1 is the heart. +(define (prec:parse1 bp) + (fluid-let ((prec:bp bp)) + (do ((left (prec:nudcall (prec:advance-return-last)) + (prec:ledcall left (prec:advance-return-last)))) + ((or (>= bp 200) ;to avoid unneccesary lookahead + (>= bp (or (prec:lbp *syn-rules* (force prec:token)) 0)) + (not left)) + left)))) + +(define (prec:delim? token) + (or (eof-object? token) (<= (or (prec:lbp *syn-rules* token) 220) 0))) + +(define (prec:parse-list sep bp) + (cond ((prec:delim? (force prec:token)) + (prec:warn 'expression-missing) + '(?)) + (else + (let ((f (prec:parse1 bp))) + (cons f (cond ((equal? (force prec:token) sep) + (prec:advance) + (cond ((equal? (force prec:token) sep) + (prec:warn 'expression-missing) + (prec:advance) + (cons '? (prec:parse-list sep bp))) + ((prec:delim? (force prec:token)) + (prec:warn 'expression-missing) + '(?)) + (else (prec:parse-list sep bp)))) + ((prec:delim? (force prec:token)) '()) + ((not sep) (prec:parse-list sep bp)) + ((prec:delim? sep) (prec:warn 'separator-missing) + (prec:parse-list sep bp)) + (else '()))))))) + +(define (prec:parse-delimited sep bp delim) + (cond ((equal? (force prec:token) sep) + (prec:warn 'expression-missing) + (prec:advance) + (cons '? (prec:parse-delimited sep delim))) + ((prec:delim? (force prec:token)) + (if (not (equal? (force prec:token) delim)) + (prec:warn 'mismatched-delimiter (force prec:token) + 'expected delim)) + (if (not sep) (prec:warn 'expression-missing)) + (prec:advance) + (if sep '() '(?))) + (else (let ((ans (prec:parse-list sep bp))) + (cond ((equal? (force prec:token) delim)) + ((prec:delim? (force prec:token)) + (prec:warn 'mismatched-delimiter (force prec:token) + 'expecting delim)) + (else (prec:warn 'delimiter-expected--ignoring-rest + (force prec:token) '...) + (do () ((prec:delim? (force prec:token))) + (prec:parse1 bp)))) + (prec:advance) + ans)))) + +(define (prec:parse grammar delim . port) + (set! delim (prec:de-symbolfy delim)) + (fluid-let ((*syn-rules* (append (prec:delim delim) grammar)) + (*prec:port* (if (null? port) (current-input-port) (car port)))) + (prec:advance) ; setup prec:token with first token + (cond ((eof-object? (force prec:token)) (force prec:token)) + ((equal? (force prec:token) delim) #f) + (else + (let ((ans (prec:parse1 0))) + (cond ((eof-object? (force prec:token))) + ((equal? (force prec:token) delim)) + (else (prec:warn 'delimiter-expected--ignoring-rest + (force prec:token) 'not delim) + (do () ((or (equal? (force prec:token) delim) + (eof-object? (force prec:token)))) + (prec:advance)))) + ans))))) + +(define tok:decimal-digits "0123456789") +(define tok:upper-case "ABCDEFGHIJKLMNOPQRSTUVWXYZ") +(define tok:lower-case "abcdefghijklmnopqrstuvwxyz") +(define tok:whitespaces + (do ((i (+ -1 (min 256 char-code-limit)) (+ -1 i)) + (ws "" (if (char-whitespace? (integer->char i)) + (string-append ws (string (integer->char i))) + ws))) + ((negative? i) ws))) + +;;;;The parse tables. +;;; Definitions accumulate in top-level variable *SYN-DEFS*. +(set! *syn-defs* '()) ;Make sure *SYN-DEFS* is empty. + +;;; Ignore Whitespace characters. +(prec:define-grammar (tok:char-group 0 tok:whitespaces #f)) + +;;; On MS-DOS systems, <ctrl>-Z (26) needs to be ignored in order to +;;; avoid problems at end of files. +(case (software-type) + ((MSDOS) + (if (not (char-whitespace? (integer->char 26))) + (prec:define-grammar (tok:char-group 0 (integer->char 26) #f)) + ))) + +;;; Save these convenient definitions. +(define *syn-ignore-whitespace* *syn-defs*) +(set! *syn-defs* '()) + +(define (prec:trace) + (require 'trace) + (trace prec:parse prec:parse1 + prec:parse-delimited prec:parse-list + prec:call-or-list prec:apply-or-cons + ;;tokenize prec:advance-return-last prec:advance + prec:nudcall prec:ledcall + prec:parse-nudcomment prec:parse-ledcomment + prec:parse-delimited prec:parse-list + prec:parse-nary prec:parse-rest + prec:parse-matchfix prec:parse-inmatchfix + prec:parse-prefix prec:parse-infix prec:parse-postfix + ;;prec:delim? + ;;prec:ledf prec:nudf prec:lbp + ) + (set! *qp-width* 333)) + +;;(begin (trace-all "prec.scm") (set! *qp-width* 333)) +;;(pretty-print (grammar-read-tab (get-grammar 'standard))) +;;(prec:trace) diff --git a/module/slib/printf.scm b/module/slib/printf.scm new file mode 100644 index 000000000..446d34655 --- /dev/null +++ b/module/slib/printf.scm @@ -0,0 +1,584 @@ +;;;; "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) + +;; Parse the output of NUMBER->STRING. +;; Returns a list: (sign-character digit-string exponent-integer) +;; SIGN-CHAR will be either #\+ or #\-, DIGIT-STRING will always begin +;; with a "0", after which a decimal point should be understood. +;; If STR denotes a non-real number, 3 additional elements for the +;; complex part are appended. +(define (stdio:parse-float str) + (let ((n (string-length str)) + (iend 0)) + (letrec ((prefix + (lambda (i rest) + (if (and (< i (- n 1)) + (char=? #\# (string-ref str i))) + (case (string-ref str (+ i 1)) + ((#\d #\i #\e) (prefix (+ i 2) rest)) + ((#\.) (rest i)) + (else (parse-error))) + (rest i)))) + (sign + (lambda (i rest) + (if (< i n) + (let ((c (string-ref str i))) + (case c + ((#\- #\+) (cons c (rest (+ i 1)))) + (else (cons #\+ (rest i)))))))) + (digits + (lambda (i rest) + (do ((j i (+ j 1))) + ((or (>= j n) + (not (or (char-numeric? (string-ref str j)) + (char=? #\# (string-ref str j))))) + (cons + (if (= i j) "0" (substring str i j)) + (rest j)))))) + (point + (lambda (i rest) + (if (and (< i n) + (char=? #\. (string-ref str i))) + (rest (+ i 1)) + (rest i)))) + (exp + (lambda (i) + (if (< i n) + (case (string-ref str i) + ((#\e #\s #\f #\d #\l #\E #\S #\F #\D #\L) + (let ((s (sign (+ i 1) (lambda (i) (digits i end!))))) + (list + (if (char=? #\- (car s)) + (- (string->number (cadr s))) + (string->number (cadr s)))))) + (else (end! i) + '(0))) + (begin (end! i) + '(0))))) + (end! + (lambda (i) + (set! iend i) + '())) + (real + (lambda (i) + (let ((parsed + (prefix + i + (lambda (i) + (sign + i + (lambda (i) + (digits + i + (lambda (i) + (point + i + (lambda (i) + (digits i exp))))))))))) + (and + parsed + (apply + (lambda (sgn idigs fdigs exp) + (let* ((digs (string-append "0" idigs fdigs)) + (n (string-length digs))) + (let loop ((i 1) + (exp (+ exp (string-length idigs)))) + (if (< i n) + (if (char=? #\0 (string-ref digs i)) + (loop (+ i 1) (- exp 1)) + (list sgn (substring digs (- i 1) n) exp)) + ;;Zero + (list sgn "0" 1))))) + parsed))))) + (parse-error + (lambda () #f))) + (let ((realpart (real 0))) + (cond ((= iend n) realpart) + ((memv (string-ref str iend) '(#\+ #\-)) + (let ((complexpart (real iend))) + (and (= iend (- n 1)) + (char-ci=? #\i (string-ref str iend)) + (append realpart complexpart)))) + ((eqv? (string-ref str iend) #\@) + ;; Polar form: No point in parsing the angle ourselves, + ;; since some transcendental approximation is unavoidable. + (let ((num (string->number str))) + (and num + (let ((realpart + (stdio:parse-float + (number->string (real-part num)))) + (imagpart + (if (real? num) + '() + (stdio:parse-float + (number->string (imag-part num)))))) + (and realpart imagpart + (append realpart imagpart)))))) + (else #f)))))) + +;; STR is a digit string representing a floating point mantissa, STR must +;; begin with "0", after which a decimal point is understood. +;; The output is a digit string rounded to NDIGS digits after the decimal +;; point implied between chars 0 and 1. +;; If STRIP-0S is not #F then trailing zeros will be stripped from the result. +;; In this case, STRIP-0S should be the minimum number of digits required +;; after the implied decimal point. +(define (stdio:round-string str ndigs strip-0s) + (let* ((n (- (string-length str) 1)) + (res + (cond ((< ndigs 0) "") + ((= n ndigs) str) + ((< n ndigs) + (let ((padlen (max 0 (- (or strip-0s ndigs) n)))) + (if (zero? padlen) + str + (string-append str + (make-string padlen + (if (char-numeric? + (string-ref str n)) + #\0 #\#)))))) + (else + (let ((res (substring str 0 (+ ndigs 1))) + (dig (lambda (i) + (let ((c (string-ref str i))) + (if (char-numeric? c) + (string->number (string c)) + 0))))) + (let ((ldig (dig (+ 1 ndigs)))) + (if (or (> ldig 5) + (and (= ldig 5) + (let loop ((i (+ 2 ndigs))) + (if (> i n) (odd? (dig ndigs)) + (if (zero? (dig i)) + (loop (+ i 1)) + #t))))) + (let inc! ((i ndigs)) + (let ((d (dig i))) + (if (< d 9) + (string-set! res i + (string-ref + (number->string (+ d 1)) 0)) + (begin + (string-set! res i #\0) + (inc! (- i 1)))))))) + res))))) + (if strip-0s + (let loop ((i (- (string-length res) 1))) + (if (or (<= i strip-0s) + (not (char=? #\0 (string-ref res i)))) + (substring res 0 (+ i 1)) + (loop (- i 1)))) + res))) + +(define (stdio:iprintf out format-string . args) + (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)) + (define (wna) + (slib:error 'printf "wrong number of arguments" + (length args) + format-string)) + + (let loop ((args args)) + (advance) + (cond + ((end-of-format?) + ;;(or (null? args) (wna)) ;Extra arguments are *not* a bug. + ) + ((eqv? #\\ fc);;Emulating C strings may not be a good idea. + (must-advance) + (and (case fc + ((#\n #\N) (out #\newline)) + ((#\t #\T) (out slib:tab)) + ;;((#\r #\R) (out #\return)) + ((#\f #\F) (out slib:form-feed)) + ((#\newline) #t) + (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 (pad pre . strs) + (let loop ((len (string-length pre)) + (ss strs)) + (cond ((>= len width) (apply string-append pre strs)) + ((null? ss) + (cond (left-adjust + (apply string-append + pre + (append strs + (list (make-string + (- width len) #\space))))) + (leading-0s + (apply string-append + pre + (make-string (- width len) #\0) + strs)) + (else + (apply string-append + (make-string (- width len) #\space) + pre strs)))) + (else + (loop (+ len (string-length (car ss))) (cdr ss)))))) + (define integer-convert + (lambda (s radix) + (cond ((not (negative? precision)) + (set! leading-0s #f) + (if (and (zero? precision) + (eqv? 0 s)) + (set! s "")))) + (set! s (cond ((symbol? s) (symbol->string s)) + ((number? s) (number->string s radix)) + ((or (not s) (null? s)) "0") + ((string? s) s) + (else "1"))) + (let ((pre (cond ((equal? "" s) "") + ((eqv? #\- (string-ref s 0)) + (set! s (substring s 1 (string-length s))) + "-") + (signed "+") + (blank " ") + (alternate-form + (case radix + ((8) "0") + ((16) "0x") + (else ""))) + (else "")))) + (pad pre + (if (< (string-length s) precision) + (make-string + (- precision (string-length s)) #\0) + "") + s)))) + (define (float-convert num fc) + (define (f digs exp strip-0s) + (let ((digs (stdio:round-string + digs (+ exp precision) (and strip-0s exp)))) + (cond ((>= exp 0) + (let* ((i0 (cond ((zero? exp) 0) + ((char=? #\0 (string-ref digs 0)) 1) + (else 0))) + (i1 (max 1 (+ 1 exp))) + (idigs (substring digs i0 i1)) + (fdigs (substring digs i1 + (string-length digs)))) + (cons idigs + (if (and (string=? fdigs "") + (not alternate-form)) + '() + (list "." fdigs))))) + ((zero? precision) + (list (if alternate-form "0." "0"))) + ((and strip-0s (string=? digs "") (list "0"))) + (else + (list "0." + (make-string (min precision (- -1 exp)) #\0) + digs))))) + (define (e digs exp strip-0s) + (let* ((digs (stdio:round-string + digs (+ 1 precision) (and strip-0s 0))) + (istrt (if (char=? #\0 (string-ref digs 0)) 1 0)) + (fdigs (substring + digs (+ 1 istrt) (string-length digs))) + (exp (if (zero? istrt) exp (- exp 1)))) + (list + (substring digs istrt (+ 1 istrt)) + (if (and (string=? fdigs "") (not alternate-form)) + "" ".") + fdigs + (if (char-upper-case? fc) "E" "e") + (if (negative? exp) "-" "+") + (if (< -10 exp 10) "0" "") + (number->string (abs exp))))) + (define (g digs exp) + (let ((strip-0s (not alternate-form))) + (set! alternate-form #f) + (cond ((<= (- 1 precision) exp precision) + (set! precision (- precision exp)) + (f digs exp strip-0s)) + (else + (set! precision (- precision 1)) + (e digs exp strip-0s))))) + (define (k digs exp sep) + (let* ((units '#("y" "z" "a" "f" "p" "n" "u" "m" "" + "k" "M" "G" "T" "P" "E" "Z" "Y")) + (base 8) ;index of "" + (uind (let ((i (if (negative? exp) + (quotient (- exp 3) 3) + (quotient (- exp 1) 3)))) + (and + (< -1 (+ i base) (vector-length units)) + i)))) + (cond (uind + (set! exp (- exp (* 3 uind))) + (set! precision (max 0 (- precision exp))) + (append + (f digs exp #f) + (list sep + (vector-ref units (+ uind base))))) + (else + (g digs exp))))) + + (cond ((negative? precision) + (set! precision 6)) + ((and (zero? precision) + (char-ci=? fc #\g)) + (set! precision 1))) + (let* ((str + (cond ((number? num) + (number->string (exact->inexact num))) + ((string? num) num) + ((symbol? num) (symbol->string num)) + (else "???"))) + (parsed (stdio:parse-float str))) + (letrec ((format-real + (lambda (signed? sgn digs exp . rest) + (if (null? rest) + (cons + (if (char=? #\- sgn) "-" + (if signed? "+" (if blank " " ""))) + (case fc + ((#\e #\E) (e digs exp #f)) + ((#\f #\F) (f digs exp #f)) + ((#\g #\G) (g digs exp)) + ((#\k) (k digs exp "")) + ((#\K) (k digs exp " ")))) + (append (format-real signed? sgn digs exp) + (apply format-real #t rest) + '("i")))))) + (if parsed + (apply pad (apply format-real signed parsed)) + (pad "???"))))) + (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))) + + ;;At this point fc completely determines the format to use. + (if (null? args) + (if (memv (char-downcase fc) + '(#\c #\s #\a #\d #\i #\u #\o #\x #\b + #\f #\e #\g #\k)) + (wna))) + + (case fc + ;; only - is allowed between % and c + ((#\c #\C) ; C is enhancement + (and (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)))) + (and (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) ;#\a #\A are pretty-print + (require 'generic-write) + (let ((os "") (pr precision)) + (generic-write + (car args) (not alternate-form) #f + (cond ((and left-adjust (negative? pr)) + (set! pr 0) + (lambda (s) + (set! pr (+ pr (string-length s))) + (out s))) + (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 ((and left-adjust (negative? precision)) + (cond + ((> width pr) (out (make-string (- width pr) #\ ))))) + (left-adjust + (cond + ((> width (- precision pr)) + (out (make-string (- width (- precision pr)) #\ ))))) + ((not os)) + ((<= width (string-length os)) (out os)) + (else (and (out (make-string + (- width (string-length os)) #\ )) + (out os))))) + (loop (cdr args))) + ((#\d #\D #\i #\I #\u #\U) + (and (out (integer-convert (car args) 10)) (loop (cdr args)))) + ((#\o #\O) + (and (out (integer-convert (car args) 8)) (loop (cdr args)))) + ((#\x #\X) + (and (out ((if (char-upper-case? fc) + string-upcase string-downcase) + (integer-convert (car args) 16))) + (loop (cdr args)))) + ((#\b #\B) + (and (out (integer-convert (car args) 2)) (loop (cdr args)))) + ((#\%) (and (out #\%) (loop args))) + ((#\f #\F #\e #\E #\g #\G #\k #\K) + (and (out (float-convert (car args) fc)) (loop (cdr args)))) + (else + (cond ((end-of-format?) (incomplete)) + (else (and (out #\%) (out fc) (out #\?) (loop args)))))))) + (else (and (out fc) (loop args))))))))) + +(define (stdio:fprintf port format . args) + (let ((cnt 0)) + (apply stdio:iprintf + (lambda (x) + (cond ((string? x) + (set! cnt (+ (string-length x) cnt)) (display x port) #t) + (else (set! cnt (+ 1 cnt)) (display x port) #t))) + format args) + cnt)) + +(define (stdio:printf format . args) + (apply stdio:fprintf (current-output-port) format args)) + +(define (stdio:sprintf str format . args) + (let* ((cnt 0) + (s (cond ((string? str) str) + ((number? str) (make-string str)) + ((not str) (make-string 100)) + (else (slib:error 'sprintf "first argument not understood" + str)))) + (end (string-length s))) + (apply stdio:iprintf + (lambda (x) + (cond ((string? x) + (if (or str (>= (- end cnt) (string-length x))) + (do ((lend (min (string-length x) (- end cnt))) + (i 0 (+ i 1))) + ((>= i lend)) + (string-set! s cnt (string-ref x i)) + (set! cnt (+ cnt 1))) + (let () + (set! s (string-append (substring s 0 cnt) x)) + (set! cnt (string-length s)) + (set! end cnt)))) + ((and str (>= cnt end))) + (else (cond ((and (not str) (>= cnt end)) + (set! s (string-append s (make-string 100))) + (set! end (string-length s)))) + (string-set! s cnt (if (char? x) x #\?)) + (set! cnt (+ cnt 1)))) + (not (and str (>= cnt end)))) + format + args) + (cond ((string? str) cnt) + ((eqv? end cnt) s) + (else (substring s 0 cnt))))) + +(define printf stdio:printf) +(define fprintf stdio:fprintf) +(define sprintf stdio:sprintf) + +;;(do ((i 0 (+ 1 i))) ((> i 50)) (printf "%s\n" (sprintf i "%#-13a:%#13a:%-13.8a:" "123456789" "123456789" "123456789"))) diff --git a/module/slib/priorque.scm b/module/slib/priorque.scm new file mode 100644 index 000000000..9002c01a6 --- /dev/null +++ b/module/slib/priorque.scm @@ -0,0 +1,136 @@ +;;;; "priorque.scm" priority queues for Scheme. +;;; Copyright (C) 1992, 1993, 1994, 1995, 1997 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) + (do ((i 7 (+ -1 i))) + ((negative? i)) + (write (heap-extract-max! heap)) (newline)))) diff --git a/module/slib/process.scm b/module/slib/process.scm new file mode 100644 index 000000000..6b0acc392 --- /dev/null +++ b/module/slib/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/module/slib/promise.scm b/module/slib/promise.scm new file mode 100644 index 000000000..f38aebfd6 --- /dev/null +++ b/module/slib/promise.scm @@ -0,0 +1,29 @@ +;;;"promise.scm" promise for force and delay +;;; From Revised^4 Report on the Algorithmic Language Scheme +;;; Editors: William Clinger and Jonathon Rees +; +; We intend this report to belong to the entire Scheme community, and so +; we grant permission to copy it in whole or in part without fee. In +; particular, we encourage implementors of Scheme to use this report as +; a starting point for manuals and other documentation, modifying it as +; necessary. + +(define promise:force (lambda (object) (object))) + +(define make-promise + (lambda (proc) + (let ((result-ready? #f) + (result #f)) + (lambda () + (if result-ready? + result + (let ((x (proc))) + (if result-ready? + result + (begin (set! result-ready? #t) + (set! result x) + result)))))))) + +;;; change occurences of (DELAY <expression>) to +;;; (MAKE-PROMISE (LAMBDA () <expression>)) +;;; and (define force promise:force) diff --git a/module/slib/pscheme.init b/module/slib/pscheme.init new file mode 100644 index 000000000..1cd117fcc --- /dev/null +++ b/module/slib/pscheme.init @@ -0,0 +1,206 @@ +;;; "pscheme.init" SLIB init file for Pocket Scheme -*-scheme-*- +;;; Author: Ben Goetter <goetter@mazama.net> +;;; last revised for 1.1.0 on 16 October 2000 +;;; Initial work for 0.2.3 by Robert Goldman (goldman@htc.honeywell.com) +;;; SLIB orig Author: Aubrey Jaffer (jaffer@ai.mit.edu) +;;; +;;; This code is in the public domain. + +; best fit for Windows CE? +(define (software-type) 'MS-DOS) + +(define (scheme-implementation-type) 'Pocket-Scheme) +(define (scheme-implementation-version) + (let ((v (version))) + (string-append + (number->string (car v)) "." + (number->string (cadr v)) "." + (number->string (caddr v))))) +(define (scheme-implementation-home-page) "http://www.mazama.net/scheme/pscheme.htm") + + +(define in-vicinity string-append) + +(define (implementation-vicinity) "\\Program Files\\Pocket Scheme\\") +(define (library-vicinity) (in-vicinity (implementation-vicinity) "slib\\")) +(define (home-vicinity) "\\My Documents\\") + +;(define (implementation-vicinity) "D:\\SRC\\PSCHEME\\BUILD\\TARGET\\X86\\NT\\DBG\\") +;(define (library-vicinity) "D:\\SRC\\SLIB\\") +;(define (home-vicinity) "D:\\SRC\\PSCHEME\\") + +(define *features* + '(source + rev4-report + ieee-p1178 + rev4-optional-procedures + multiarg/and- + multiarg-apply + with-file + char-ready? + defmacro + rationalize + delay + eval + dynamic-wind + full-continuation +; Undef this to get the SLIB TRACE macros +; trace + system + string-port + )) + + +;;; (OUTPUT-PORT-WIDTH <port>) +;;; (OUTPUT-PORT-HEIGHT <port>) +;; $BUGBUG completely bogus values. +(define (output-port-width . arg) 79) +(define (output-port-height . arg) 12) + +;;; (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) + (with-handlers (((lambda (x) #t) (lambda (x) #f))) + (close-input-port (open-input-file f)) + #t)) + +;; pscheme: current-error-port, delete-file, force-output already defined + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +;(define char-code-limit +; (with-handlers ( +; ((lambda (x) #t) (lambda (x) 256)) +; ) +; (integer->char 65535) +; 65536)) +;;; Currently there are only three clients of this symbol. +;;; Following observations relate to PScheme 0.3.5, JACAL 1a9, SLIB 2c5. +;;; JACAL: crashes when set to 65536. +;;; make-crc: extremely inefficient when set to 65536, spending forever in init +;;; precedence-parse: ignores any setting in excess of 256 +;;; So we patch it to 256. +(define char-code-limit 256) + +;;; MOST-POSITIVE-FIXNUM is used in modular.scm +;;; This is the most positive immediate-value fixnum in PScheme. +(define most-positive-fixnum #x07FFFFFF) + +;;; Return argument +(define (identity x) x) + +;;; 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 defmacro in terms of our define-macro +(define-macro (defmacro name args . body) + `(define-macro (,name ,@args) ,@body)) + +; following defns removed in 0.6.3 while I rethink macro support +;(define defmacro? macro?) +;(define macroexpand expand-macro) +;(define macroexpand-1 expand-macro-1) + +(define gentemp gensym) + +(define base:eval slib:eval) +(define defmacro: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))))) + +(define (defmacro:load <pathname>) + (slib:eval-load <pathname> defmacro:eval)) + +(define slib:warn + (lambda args + (let ((port (current-error-port))) + (display "Warn: " port) + (for-each (lambda (x) (display x port)) args)))) + +;;; Define an error procedure for the library +(define slib:error error) + +;;; As announced by feature string-port +(define (call-with-output-string t) + (let* ((p (open-output-string)) + (r (t p)) + (s (get-output-string p))) + (close-output-port p) + s)) + +(define (call-with-input-string s t) + (let* ((p (open-input-string s)) + (r (t p))) + (close-input-port p) + r)) + +;;; 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 SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:exit 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) + (if (not (file-exists? f)) + (set! f (string-append f (scheme-file-suffix)))) + (load f)) + +;;; (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) + +;;; Pscheme and SLIB both define REQUIRE, so dispatch on argument type. +;;; The SLIB REQUIRE does accept strings, though this facility seems never to be used. +(define pscheme:require require) +(slib:load (in-vicinity (library-vicinity) "require")) +(define slib:require require) +(define (require x) + (if (string? x) (pscheme:require x) (slib:require x))) diff --git a/module/slib/psxtime.scm b/module/slib/psxtime.scm new file mode 100644 index 000000000..5322c448a --- /dev/null +++ b/module/slib/psxtime.scm @@ -0,0 +1,155 @@ +;;;; "psxtime.scm" Posix time conversion routines +;;; Copyright (C) 1994, 1997 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, it doesn't do leap seconds. + +(define time: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))) +(define (leap-year? year) + (and (zero? (remainder year 4)) + (or (not (zero? (remainder year 100))) + (zero? (remainder year 400))))) ; Leap years. + +;;; 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* ((secs (modulo t 86400)) ; SECS/DAY + (days (+ (quotient t 86400) ; SECS/DAY + (if (and (negative? t) (positive? secs)) -1 0)))) + (let ((tm_hour (quotient secs 3600)) + (secs (remainder secs 3600)) + (tm_wday (modulo (+ 4 days) 7))) ; January 1, 1970 was a Thursday. + (let loop ((tm_year 1970) + (tm_yday days)) + (let ((diy (if (leap-year? tm_year) 366 365))) + (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 time: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 caltime . tz) + (require 'time-zone) + (set! tz (if (null? tz) (tzset) (car tz))) + (apply time:split caltime (tz:params caltime tz))) + +(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 univtime . tz) + (require 'time-zone) + (set! tz (if (null? tz) (tzset) (car tz))) + (+ (gmktime univtime) (tz:std-offset tz))) + +(define (time:gmktime univtime) + (time:invert time:gmtime univtime)) + +(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 . args) + (time:asctime (apply time:localtime args))) + +(define (time:gtime time) + (time:asctime (time:gmtime time))) + +;;; GMT Local -- take optional 2nd TZ arg +(define gmtime time:gmtime) (define localtime time:localtime) +(define gmktime time:gmktime) (define mktime time:mktime) +(define gtime time:gtime) (define ctime time:ctime) + +(define asctime time:asctime) diff --git a/module/slib/qp.scm b/module/slib/qp.scm new file mode 100644 index 000000000..ab6815cfa --- /dev/null +++ b/module/slib/qp.scm @@ -0,0 +1,149 @@ +;;;; "qp.scm" Print finite length representation for any Scheme object. +;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define *qp-width* (output-port-width (current-output-port))) + +(define qp: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 + ((or (not *qp-width*) (= 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:qpn + (let ((newline newline) (apply apply) (qp:qp qp:qp)) + (lambda objs (apply qp:qp objs) (newline)))) + +(define qp:qpr + (let ((- -) (apply apply) (length length) (list-ref list-ref) (qp:qpn qp:qpn)) + (lambda objs (apply qp:qpn objs) + (list-ref objs (- (length objs) 1))))) + +(define qp qp:qp) +(define qpn qp:qpn) +(define qpr qp:qpr) diff --git a/module/slib/queue.scm b/module/slib/queue.scm new file mode 100644 index 000000000..89a65b066 --- /dev/null +++ b/module/slib/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/module/slib/r4rsyn.scm b/module/slib/r4rsyn.scm new file mode 100644 index 000000000..500d68c61 --- /dev/null +++ b/module/slib/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/module/slib/randinex.scm b/module/slib/randinex.scm new file mode 100644 index 000000000..46f8c9fae --- /dev/null +++ b/module/slib/randinex.scm @@ -0,0 +1,127 @@ +;;;"randinex.scm" Pseudo-Random inexact real numbers for scheme. +;;; Copyright (C) 1991, 1993, 1999 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. + +;;; Sphere and normal functions corrections from: Harald Hanche-Olsen + +;;; Generate an inexact real between 0 and 1. +(define random:uniform1 + ; how many chunks fill an inexact? + (do ((random:chunks/float 0 (+ 1 random:chunks/float)) + (smidgen 1.0 (/ smidgen 256.0))) + ((or (= 1.0 (+ 1 smidgen)) (= 4 random:chunks/float)) + (lambda (state) + (do ((cnt random:chunks/float (+ -1 cnt)) + (uni (/ (random:chunk state) 256.0) + (/ (+ uni (random:chunk state)) 256.0))) + ((= 1 cnt) uni)))))) + + +;;@args +;;@args state +;;Returns an uniformly distributed inexact real random number in the +;;range between 0 and 1. +(define (random:uniform . args) + (random:uniform1 (if (null? args) *random-state* (car args)))) + + +;;@args +;;@args state +;;Returns an inexact real in an exponential distribution with mean 1. For +;;an exponential distribution with mean @var{u} use +;;@w{@code{(* @var{u} (random:exp))}}. +(define (random:exp . args) + (- (log (random:uniform1 (if (null? args) *random-state* (car args)))))) + + +;;@args +;;@args 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 +;;@w{@code{(+ @var{m} (* @var{d} (random:normal)))}}. +(define (random:normal . args) + (let ((vect (make-vector 1))) + (apply random:normal-vector! vect args) + (vector-ref vect 0))) + + +;;; 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 *2pi (* 8 (atan 1))) + +;;@args vect +;;@args vect state +;;Fills @1 with inexact real random numbers which are independent +;;and standard normally distributed (i.e., with mean 0 and variance 1). +(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 (* *2pi (random:uniform1 state))) + (r (sqrt (* -2 (log (random:uniform1 state)))))) + (do! n (* r (cos t))) + (if (positive? n) (do! (- n 1) (* r (sin t))))))))) + + +;;; For the uniform distibution on the hollow sphere, pick a normal +;;; family and scale. + +;;@args vect +;;@args vect state +;;Fills @1 with inexact real random numbers the sum of whose +;;squares is equal to 1.0. Thinking of @1 as coordinates in space +;;of dimension n = @code{(vector-length @1)}, the coordinates are +;;uniformly distributed over the surface of the unit n-shere. +(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 can be +;;; generated as r=u^(1/n). + +;;@args vect +;;@args vect state +;;Fills @1 with inexact real random numbers the sum of whose +;;squares is less than 1.0. Thinking of @1 as coordinates in +;;space of dimension @var{n} = @code{(vector-length @1)}, the +;;coordinates are uniformly distributed within the unit @var{n}-shere. +;;The sum of the squares of the numbers is returned. +(define (random:solid-sphere! vect . args) + (apply random:hollow-sphere! vect args) + (let ((r (expt (random:uniform1 (if (null? args) *random-state* (car args))) + (/ (vector-length vect))))) + (do ((n (- (vector-length vect) 1) (- n 1))) + ((negative? n) r) + (vector-set! vect n (* r (vector-ref vect n)))))) diff --git a/module/slib/randinex.txi b/module/slib/randinex.txi new file mode 100644 index 000000000..80531ebe8 --- /dev/null +++ b/module/slib/randinex.txi @@ -0,0 +1,56 @@ + +@defun random:uniform + + +@defunx random:uniform state +Returns an uniformly distributed inexact real random number in the +range between 0 and 1. +@end defun + +@defun random:exp + + +@defunx random:exp state +Returns an inexact real in an exponential distribution with mean 1. For +an exponential distribution with mean @var{u} use +@w{@code{(* @var{u} (random:exp))}}. +@end defun + +@defun random:normal + + +@defunx 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 +@w{@code{(+ @var{m} (* @var{d} (random:normal)))}}. +@end defun + +@defun random:normal-vector! vect + + +@defunx 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 defun + +@defun random:hollow-sphere! vect + + +@defunx 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. +@end defun + +@defun random:solid-sphere! vect + + +@defunx 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. +@end defun diff --git a/module/slib/random.scm b/module/slib/random.scm new file mode 100644 index 000000000..dc4c3fb25 --- /dev/null +++ b/module/slib/random.scm @@ -0,0 +1,139 @@ +;;;; "random.scm" Pseudo-Random number generator for scheme. +;;; Copyright (C) 1991, 1993, 1998, 1999 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 'byte) +(require 'logical) + +;;; random:chunk returns an integer in the range of 0 to 255. +(define (random:chunk sta) + (cond ((positive? (byte-ref sta 258)) + (byte-set! sta 258 0) + (slib:error "random state called reentrantly"))) + (byte-set! sta 258 1) + (let* ((idx (logand #xff (+ 1 (byte-ref sta 256)))) + (xtm (byte-ref sta idx)) + (idy (logand #xff (+ (byte-ref sta 257) xtm)))) + (byte-set! sta 256 idx) + (byte-set! sta 257 idy) + (let ((ytm (byte-ref sta idy))) + (byte-set! sta idy xtm) + (byte-set! sta idx ytm) + (let ((ans (byte-ref sta (logand #xff (+ ytm xtm))))) + (byte-set! sta 258 0) + ans)))) + + +;;@args n +;;@args n state +;;Accepts a positive integer or real @1 and returns a number of the +;;same type between zero (inclusive) and @1 (exclusive). The values +;;returned by @0 are uniformly distributed from 0 to @1. +;; +;;The optional argument @var{state} must be of the type returned by +;;@code{(seed->random-state)} or @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 calls to @code{random}. +(define (random modu . args) + (let ((state (if (null? args) *random-state* (car args)))) + (if (exact? modu) + (letrec ((bitlen (integer-length (+ -1 modu))) + (rnd (lambda () + (do ((bln bitlen (+ -8 bln)) + (rbs 0 (+ (ash rbs 8) (random:chunk state)))) + ((<= bln 7) + (set! rbs (+ (ash rbs bln) + (bit-field (random:chunk state) 0 bln))) + (and (< rbs modu) rbs)))))) + (do ((ans (rnd) (rnd))) (ans ans))) + (* (random:uniform1 state) modu)))) + +(define random:random random) +;;;random:uniform is in randinex.scm. It is needed only if inexact is +;;;supported. + + +;;@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. +;;@end defvar + + +;;@args state +;;Returns a new copy of argument @1. +;; +;;@args +;;Returns a new copy of @code{*random-state*}. +(define (copy-random-state . sta) + (copy-string (if (null? sta) *random-state* (car sta)))) + + +;;@body +;;Returns a new object of type suitable for use as the value of the +;;variable @code{*random-state*} or as a second argument to @code{random}. +;;The number or string @1 is used to initialize the state. If +;;@0 is called twice with arguments which are +;;@code{equal?}, then the returned data structures will be @code{equal?}. +;;Calling @0 with unequal arguments will nearly +;;always return unequal states. +(define (seed->random-state seed) + (define sta (make-bytes (+ 3 256) 0)) + (if (number? seed) (set! seed (number->string seed))) + ; initialize state + (do ((idx #xff (+ -1 idx))) + ((negative? idx)) + (byte-set! sta idx idx)) + ; merge seed into state + (do ((i 0 (+ 1 i)) + (j 0 (modulo (+ 1 j) seed-len)) + (seed-len (bytes-length seed)) + (k 0)) + ((>= i 256)) + (let ((swp (byte-ref sta i))) + (set! k (logand #xff (+ k (byte-ref seed j) swp))) + (byte-set! sta i (byte-ref sta k)) + (byte-set! sta k swp))) + sta) + + +;;@args +;;@args obj +;;Returns a new object of type suitable for use as the value of the +;;variable @code{*random-state*} or as a second argument to @code{random}. +;;If the optional argument @var{obj} is given, it should be a printable +;;Scheme object; the first 50 characters of its printed representation +;;will be used as the seed. Otherwise the value of @code{*random-state*} +;;is used as the seed. +(define (make-random-state . args) + (let ((seed (if (null? args) *random-state* (car args)))) + (cond ((string? seed)) + ((number? seed) (set! seed (number->string seed))) + (else (let () + (require 'object->string) + (set! seed (object->limited-string seed 50))))) + (seed->random-state seed))) + +(define *random-state* + (make-random-state "http://swissnet.ai.mit.edu/~jaffer/SLIB.html")) + +(provide 'random) ;to prevent loops +(if (provided? 'inexact) (require 'random-inexact)) diff --git a/module/slib/random.txi b/module/slib/random.txi new file mode 100644 index 000000000..d9474f9b4 --- /dev/null +++ b/module/slib/random.txi @@ -0,0 +1,55 @@ + +@defun random n + + +@defunx 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 by @code{random} are uniformly distributed from 0 to @var{n}. + +The optional argument @var{state} must be of the type returned by +@code{(seed->random-state)} or @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 calls to @code{random}. +@end defun +@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. +@end defvar + + +@defun copy-random-state state + +Returns a new copy of argument @var{state}. + + +@defunx copy-random-state +Returns a new copy of @code{*random-state*}. +@end defun + +@defun seed->random-state seed + +Returns a new object of type suitable for use as the value of the +variable @code{*random-state*} or as a second argument to @code{random}. +The number or string @var{seed} is used to initialize the state. If +@code{seed->random-state} is called twice with arguments which are +@code{equal?}, then the returned data structures will be @code{equal?}. +Calling @code{seed->random-state} with unequal arguments will nearly +always return unequal states. +@end defun + +@defun make-random-state + + +@defunx make-random-state obj +Returns a new object of type suitable for use as the value of the +variable @code{*random-state*} or as a second argument to @code{random}. +If the optional argument @var{obj} is given, it should be a printable +Scheme object; the first 50 characters of its printed representation +will be used as the seed. Otherwise the value of @code{*random-state*} +is used as the seed. +@end defun diff --git a/module/slib/ratize.scm b/module/slib/ratize.scm new file mode 100644 index 000000000..973793449 --- /dev/null +++ b/module/slib/ratize.scm @@ -0,0 +1,17 @@ +;;;; "ratize.scm" Find simplest number ratios + +(define (find-ratio-between x y) + (define (sr x y) + (let ((fx (inexact->exact (floor x))) (fy (inexact->exact (floor y)))) + (cond ((>= fx x) (list fx 1)) + ((= fx fy) (let ((rat (sr (/ (- y fy)) (/ (- x fx))))) + (list (+ (cadr rat) (* fx (car rat))) (car rat)))) + (else (list (+ 1 fx) 1))))) + (cond ((< y x) (find-ratio-between y x)) + ((>= x y) (list x 1)) + ((positive? x) (sr x y)) + ((negative? y) (let ((rat (sr (- y) (- x)))) + (list (- (car rat)) (cadr rat)))) + (else '(0 1)))) +(define (find-ratio x e) (find-ratio-between (- x e) (+ x e))) +(define (rationalize x e) (apply / (find-ratio x e))) diff --git a/module/slib/rdms.scm b/module/slib/rdms.scm new file mode 100644 index 000000000..a6ba95f7f --- /dev/null +++ b/module/slib/rdms.scm @@ -0,0 +1,629 @@ +;;; "rdms.scm" rewrite 6 - the saga continues +; Copyright 1994, 1995, 1997, 2000 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)))) + number + #f) + (number #f number? number #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 slib:warn) +(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) + (let ((ans (write-base lldb filename))) + (and ans (set! rdms:filename filename)) + ans)) + + (define (sync-database) + (sync-base lldb)) + + (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 ((not cat:row) + (rdms:error "can't open-table:" table-name)) + ((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-foreign-check-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))) + (and (not (eq? foreign-name table-name)) + foreign-name)) + column-foreign-list)) + (set! column-foreign-check-list + (cons + (let ((foreign-name (car column-foreign-list))) + (and foreign-name + (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-check-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)) + (letrec ((export-method + (lambda (name proc) + (set! export-alist + (cons (cons name proc) export-alist)))) + (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))))) + (accumulate-over-table + (lambda (operation) + (lambda mkeys (base:map-primary-key + base-table operation + primary-limit column-type-list + (norm-mkeys mkeys))))) + (norm-mkeys + (lambda (mkeys) + (define mlim (length mkeys)) + (cond ((> mlim primary-limit) + (rdms:error "too many keys:" mkeys)) + ((= mlim primary-limit) mkeys) + (else + (append mkeys + (do ((k (- primary-limit mlim) (+ -1 k)) + (result '() (cons #f result))) + ((<= k 0) result)))))))) + (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 . mkeys) + (base:ordered-for-each-key + base-table (lambda (ckey) (proc (r ckey))) + primary-limit column-type-list + (norm-mkeys mkeys))))) + (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-check-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)) + (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* + (lambda mkeys + (base:delete* base-table + primary-limit column-type-list + (norm-mkeys mkeys)))) + (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? + (case (car args) + ((get) (lambda gkeys + (and (present? base-table (list->key gkeys)) + (list-ref gkeys (+ -1 ci))))) + ((get*) (let ((key-extractor + ((base 'make-key-extractor) + primary-limit column-type-list ci))) + (lambda mkeys + (base:map-primary-key + base-table + (lambda (ckey) (key-extractor ckey)) + primary-limit column-type-list + (norm-mkeys mkeys))))) + (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 mkeys + (base:map-primary-key + base-table + (lambda (ckey) + (list-ref (base:get base-table ckey) + index)) + primary-limit column-type-list + (norm-mkeys mkeys)))) + (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) + ((sync-database) sync-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/module/slib/recobj.scm b/module/slib/recobj.scm new file mode 100644 index 000000000..36ab6d284 --- /dev/null +++ b/module/slib/recobj.scm @@ -0,0 +1,55 @@ +;;; "recobj.scm" Records implemented as objects. +;;;From: whumeniu@datap.ca (Wade Humeniuk) + +(require 'object) +(require 'common-list-functions) + +(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-name) + (let ((index (comlist:position field-name 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/module/slib/record.scm b/module/slib/record.scm new file mode 100644 index 000000000..a1a9450a3 --- /dev/null +++ b/module/slib/record.scm @@ -0,0 +1,228 @@ +; "record.scm" record data types +; Written by David Carlton, carlton@husc.harvard.edu. +; Re-Written by Aubrey Jaffer, jaffer@ai.mit.edu, 1996, 1997 +; +; 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 display display) +(define write write) + +(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) + (disp display) + (wri write) + + ;; 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) (if (vector? rtd) (vect-ref rtd 1) "rtd"))) + (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))) + (rec-disp-str + (lambda (x) + (let ((name (rtd-name (rec-rtd x)))) + (string-append + "#<" (if (symbol? name) (symbol->string name) name) ">")))) + + (make-rec-type + (lambda (type-name field-names) + (if (not (or (symbol? type-name) (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)) (vect? 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) + (cond ((rec? vector) + (vec:error 'vector->list nvt vector)) + (else (vect->list vector))))) + (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! display + (lambda (obj . opt) + (apply disp (if (rec? obj) (rec-disp-str obj) obj) opt))) + (set! write + (lambda (obj . opt) + (if (rec? obj) + (apply disp (rec-disp-str obj) opt) + (apply wri obj opt)))) + (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/module/slib/repl.scm b/module/slib/repl.scm new file mode 100644 index 000000000..f51f4932d --- /dev/null +++ b/module/slib/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/module/slib/report.scm b/module/slib/report.scm new file mode 100644 index 000000000..64f4d4688 --- /dev/null +++ b/module/slib/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/module/slib/require.scm b/module/slib/require.scm new file mode 100644 index 000000000..3a6b612d8 --- /dev/null +++ b/module/slib/require.scm @@ -0,0 +1,274 @@ +;;;; Implementation of VICINITY and MODULES for Scheme +;Copyright (C) 1991, 1992, 1993, 1994, 1997 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* "2d1") + +;;; 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 *load-pathname* #f) +(define vicinity:suffix? + (let ((suffi + (case (software-type) + ((AMIGA) '(#\: #\/)) + ((MACOS THINKC) '(#\:)) + ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT) '(#\/)) + ((VMS) '(#\: #\]))))) + (lambda (chr) (memv chr suffi)))) +(define (program-vicinity) + (if *load-pathname* + (let loop ((i (- (string-length *load-pathname*) 1))) + (cond ((negative? i) "") + ((vicinity:suffix? (string-ref *load-pathname* i)) + (substring *load-pathname* 0 (+ i 1))) + (else (loop (- i 1))))) + (slib:error "Not loading but called" 'program-vicinity))) + +(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) ".") + ((MACOS THINKC) ":") + ((MS-DOS WINDOWS ATARIST OS/2) "\\") + ((UNIX COHERENT AMIGA) "/")))) + (lambda (vic name) + (string-append vic name *vicinity-suffix*)))))) + +(define (make-vicinity <pathname>) <pathname>) + +(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 *catalog* #f) +(define *modules* '()) + +(define (require:version path) + (let ((expr (and (file-exists? path) + (call-with-input-file path (lambda (port) (read port)))))) + (and (list? expr) (= 3 (length expr)) + (eq? (car expr) 'define) (eq? (cadr expr) '*SLIB-VERSION*) + (string? (caddr expr)) (caddr expr)))) + +(define (catalog/require-version-match? slibcat) + (let* ((apair (assq '*SLIB-VERSION* slibcat)) + (req (in-vicinity (library-vicinity) + (string-append "require" (scheme-file-suffix)))) + (reqvers (require:version req))) + (cond ((not (file-exists? req)) + (slib:warn "can't find " req) #f) + ((not apair) #f) + ((not (equal? reqvers (cdr apair))) #f) + ((not (equal? reqvers *SLIB-VERSION*)) + (slib:warn "The loaded " req " is stale.") + #t) + (else #t)))) + +(define (catalog:try-read vicinity name) + (or (and vicinity name + (let ((path (in-vicinity vicinity name))) + (and (file-exists? path) + (call-with-input-file path + (lambda (port) + (do ((expr (read port) (read port)) + (lst '() (cons expr lst))) + ((eof-object? expr) + (apply append lst)))))))) + '())) + +(define (catalog:get feature) + (if (not *catalog*) + (let ((slibcat (catalog:try-read (implementation-vicinity) "slibcat"))) + (cond ((not (catalog/require-version-match? slibcat)) + (slib:load (in-vicinity (library-vicinity) "mklibcat")) + (set! slibcat + (catalog:try-read (implementation-vicinity) "slibcat")))) + (cond (slibcat + (set! *catalog* ((slib:eval + (cadr (or (assq 'catalog:filter slibcat) + '(#f identity)))) + slibcat)))) + (set! *catalog* + (append (catalog:try-read (home-vicinity) "homecat") *catalog*)) + (set! *catalog* + (append (catalog:try-read (user-vicinity) "usercat") *catalog*)))) + (and feature *catalog* (cdr (or (assq feature *catalog*) '(#f . #f))))) + +(define (require:provided? feature) + (if (symbol? feature) + (if (memq feature *features*) #t + (and *catalog* + (let ((path (catalog:get feature))) + (cond ((symbol? path) (require:provided? path)) + ((member (if (pair? path) (cdr path) path) *modules*) + #t) + (else #f))))) + (and (member feature *modules*) #t))) + +(define (require:feature->path feature) + (and (symbol? feature) + (let ((path (catalog:get feature))) + (if (symbol? path) (require:feature->path path) path)))) + +(define (require:require feature) + (or (require:provided? feature) + (let ((path (catalog:get feature))) + (cond ((and (not path) (string? feature) (file-exists? feature)) + (set! path feature))) + (cond ((not feature) (set! *catalog* #f)) + ((not path) + (slib:error ";required feature not supported: " feature)) + ((symbol? path) (require:require path) (require:provide feature)) + ((not (pair? path)) ;simple name + (slib:load path) + (and (not (eq? 'new-catalog feature)) (require:provide feature))) + (else ;special loads + (require: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) + (else (slib:error "unknown package loader" path))) + (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) + +(if (and (string->number "0.0") (inexact? (string->number "0.0"))) + (require:provide 'inexact)) +(if (rational? (string->number "1/19")) (require:provide 'rational)) +(if (real? (string->number "0.0")) (require:provide 'real)) +(if (complex? (string->number "1+i")) (require:provide 'complex)) +(let ((n (string->number "9999999999999999999999999999999"))) + (if (and n (exact? n)) (require:provide 'bignum))) + +(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*)) + (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) + (report:print 'Implementation '*CATALOG* ':) + (catalog:get #f) + (cond ((pair? args) + (for-each (lambda (x) (display slib:tab) (report:print x)) + *catalog*)) + (else (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/module/slib/root.scm b/module/slib/root.scm new file mode 100644 index 000000000..d561af6b1 --- /dev/null +++ b/module/slib/root.scm @@ -0,0 +1,217 @@ +;;;"root.scm" Newton's and Laguerre's methods for finding roots. +;Copyright (C) 1996, 1997 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) + +;;;; 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)))))))) + +(define (secant:find-root-1 f x0 x1 prec must-bracket?) + (letrec ((stop? + (cond ((procedure? prec) prec) + ((and (integer? prec) (negative? prec)) + (lambda (x0 x1 fmax count) + (>= count (- prec)))) + (else + (lambda (x0 f0 x1 f1 count) + (and (< (abs f0) prec) + (< (abs f1) prec)))))) + (bracket-iter + (lambda (xlo flo glo xhi fhi ghi count) + (define (step xnew fnew) + (cond ((or (= xnew xlo) + (= xnew xhi)) + (let ((xmid (+ xlo (* 1/2 (- xhi xlo))))) + (if (= xnew xmid) + xmid + (step xmid (f xmid))))) + ((positive? fnew) + (bracket-iter xlo flo (if glo (* 0.5 glo) 1) + xnew fnew #f + (+ count 1))) + (else + (bracket-iter xnew fnew #f + xhi fhi (if ghi (* 0.5 ghi) 1) + (+ count 1))))) + (if (stop? xlo flo xhi fhi count) + (if (> (abs flo) (abs fhi)) xhi xlo) + (let* ((fflo (if glo (* glo flo) flo)) + (ffhi (if ghi (* ghi fhi) fhi)) + (del (- (/ fflo (- ffhi fflo)))) + (xnew (+ xlo (* del (- xhi xlo)))) + (fnew (f xnew))) + (step xnew fnew)))))) + (let ((f0 (f x0)) + (f1 (f x1))) + (cond ((<= f0 0 f1) + (bracket-iter x0 f0 #f x1 f1 #f 0)) + ((<= f1 0 f0) + (bracket-iter x1 f1 #f x0 f0 #f 0)) + (must-bracket? #f) + (else + (let secant-iter ((x0 x0) + (f0 f0) + (x1 x1) + (f1 f1) + (count 0)) + (cond ((stop? x0 f0 x1 f1 count) + (if (> (abs f0) (abs f1)) x1 x0)) + ((<= f0 0 f1) + (bracket-iter x0 f0 #f x1 f1 #f count)) + ((>= f0 0 f1) + (bracket-iter x1 f1 #f x0 f0 #f count)) + ((= f0 f1) #f) + (else + (let* ((xnew (+ x0 (* (- (/ f0 (- f1 f0))) (- x1 x0)))) + (fnew (f xnew)) + (fmax (max (abs f1) (abs fnew)))) + (secant-iter x1 f1 xnew fnew (+ count 1))))))))))) + +(define (secant:find-root f x0 x1 prec) + (secant:find-root-1 f x0 x1 prec #f)) +(define (secant:find-bracketed-root f x0 x1 prec) + (secant:find-root-1 f x0 x1 prec #t)) diff --git a/module/slib/sc2.scm b/module/slib/sc2.scm new file mode 100644 index 000000000..5a10f8409 --- /dev/null +++ b/module/slib/sc2.scm @@ -0,0 +1,66 @@ +;"sc2.scm" Implementation of rev2 procedures eliminated in subsequent versions. +; Copyright (C) 1991, 1993 Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define (substring-move-left! string1 start1 end1 string2 start2) + (do ((i start1 (+ i 1)) + (j start2 (+ j 1)) + (l (- end1 start1) (- l 1))) + ((<= l 0)) + (string-set! string2 j (string-ref string1 i)))) + +(define (substring-move-right! string1 start1 end1 string2 start2) + (do ((i (+ start1 (- end1 start1) -1) (- i 1)) + (j (+ start2 (- end1 start1) -1) (- j 1)) + (l (- end1 start1) (- l 1))) + ((<= l 0)) + (string-set! string2 j (string-ref string1 i)))) + +(define (substring-fill! string start end char) + (do ((i start (+ i 1)) + (l (- end start) (- l 1))) + ((<= l 0)) + (string-set! string i char))) + +(define (string-null? str) + (= 0 (string-length str))) + +(define append! + (lambda args + (cond ((null? args) '()) + ((null? (cdr args)) (car args)) + ((null? (car args)) (apply append! (cdr args))) + (else + (set-cdr! (last-pair (car args)) + (apply append! (cdr args))) + (car args))))) + +;;;; need to add code for OBJECT-HASH and OBJECT-UNHASH + +(define 1+ + (let ((+ +)) + (lambda (n) (+ n 1)))) +(define -1+ + (let ((+ +)) + (lambda (n) (+ n -1)))) + +(define <? <) +(define <=? <=) +(define =? =) +(define >? >) +(define >=? >=) diff --git a/module/slib/sc4opt.scm b/module/slib/sc4opt.scm new file mode 100644 index 000000000..176d7f1ce --- /dev/null +++ b/module/slib/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/module/slib/sc4sc3.scm b/module/slib/sc4sc3.scm new file mode 100644 index 000000000..968785690 --- /dev/null +++ b/module/slib/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/module/slib/scaexpp.scm b/module/slib/scaexpp.scm new file mode 100644 index 000000000..aa058a650 --- /dev/null +++ b/module/slib/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/module/slib/scaglob.scm b/module/slib/scaglob.scm new file mode 100644 index 000000000..32a027c1d --- /dev/null +++ b/module/slib/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/module/slib/scainit.scm b/module/slib/scainit.scm new file mode 100644 index 000000000..93fed1e42 --- /dev/null +++ b/module/slib/scainit.scm @@ -0,0 +1,104 @@ +;;; "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) + (string-append 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/module/slib/scamacr.scm b/module/slib/scamacr.scm new file mode 100644 index 000000000..016d7fbcd --- /dev/null +++ b/module/slib/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/module/slib/scanf.scm b/module/slib/scanf.scm new file mode 100644 index 000000000..a30295197 --- /dev/null +++ b/module/slib/scanf.scm @@ -0,0 +1,350 @@ +;;;;"scanf.scm" implemenation of formated input +;Copyright (C) 1996, 1997 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 ((and report-field? (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)) + (c (peek-char input-port) (peek-char input-port))) + ((or (>= i width) + (eof-object? c)) + (add-item report-field? (substring str 0 i))) + (string-set! str i (read-input-char))))) + ((#\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)))) + ;;(trace flush-whitespace-input flush-whitespace add-item return read-string read-word loop1) + (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 2 not a 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/module/slib/scaoutp.scm b/module/slib/scaoutp.scm new file mode 100644 index 000000000..b9730caca --- /dev/null +++ b/module/slib/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/module/slib/scheme2c.init b/module/slib/scheme2c.init new file mode 100644 index 000000000..e8407a8d3 --- /dev/null +++ b/module/slib/scheme2c.init @@ -0,0 +1,304 @@ +;;; "scheme2c.init" Initialisation for SLIB for Scheme->C on Sun -*-scheme-*- +;;; Authors: David Love and Aubrey Jaffer +;;; +;;; This code is in the public domain. + +;;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-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) #f) + +;;; (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))) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define home-vicinity + (let ((home-path (getenv "HOME"))) + (lambda () home-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)) + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; 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) + +;;; 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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;; define an error procedure for the library +(define (slib:error . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (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/module/slib/scheme48.init b/module/slib/scheme48.init new file mode 100644 index 000000000..d109a7a59 --- /dev/null +++ b/module/slib/scheme48.init @@ -0,0 +1,282 @@ +;;;"scheme48.init" Initialisation for SLIB for Scheme48 -*-scheme-*- +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. + +;;; 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-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) + "http://www.neci.nj.nec.com/homepages/kelsey.html") + +;;; (scheme-implementation-version) should return a string describing +;;; the version of the scheme implementation loading this file. + +(define scheme-implementation-version + (cond ((= -86400 (modulo -2177452800 -86400)) + (display "scheme48-0.36 has been superseded by") + (newline) + (display "http://swissnet.ai.mit.edu/ftpdir/s48/scheme48-0.46.tgz") + (newline) + (lambda () "0.36")) + (else (lambda () "0.46")))) + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxiliary files to your Scheme +;;; implementation reside. + +;;; [ defined from the Makefile ] + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +;;; [ defined from the Makefile ] + +(define getenv s48-getenv) +(define system s48-system) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define home-vicinity + (let ((home-path (getenv "HOME"))) + (lambda () home-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 ;conforms to + ieee-p1178 ;conforms to + rev4-optional-procedures + multiarg/and- + multiarg-apply + rationalize + delay ;has delay and force + with-file + char-ready? ;has + eval ;proposed 2-argument eval + values ;proposed multiple values + dynamic-wind ;proposed dynamic-wind + full-continuation ;can return multiple times + macro ;R4RS appendix's DEFINE-SYNTAX + system ;posix (system <string>) + getenv ;posix (getenv <string>) + )) + +;;; (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 s48-current-error-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) + (call-with-current-continuation + (lambda (k) + (s48-with-handler + (lambda (condition decline) + (k #f)) + (lambda () + (close-input-port (open-input-file f)) + #t))))) + +;;; (DELETE-FILE <string>) +(define (delete-file file-name) + (s48-system (string-append "rm " file-name))) + +;;; 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) + (s48-force-output + (if (null? arg) (current-output-port) (car arg)))) + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +(define integer->char s48-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) + +;;; 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 <pathname>) + (if (not (file-exists? <pathname>)) + (set! <pathname> (string-append <pathname> (scheme-file-suffix)))) + (load <pathname>)) + +(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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;;; define an error procedure for the library +(define (slib:error . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (apply s48-error args)) + +;;; define these as appropriate for your system. +(define slib:tab (s48-ascii->char 9)) +(define slib:form-feed (s48-ascii->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) + +;;; Scheme48 complains that these are not defined (even though they +;;; won't be called until they are). +(define synclo:load #f) +(define syncase:load #f) +(define macwork:load #f) +(define transcript-on #f) +(define transcript-off #f) + +(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/module/slib/schmooz.scm b/module/slib/schmooz.scm new file mode 100644 index 000000000..8396623e7 --- /dev/null +++ b/module/slib/schmooz.scm @@ -0,0 +1,628 @@ +;;; "schmooz.scm" Program for extracting texinfo comments from Scheme. +;;; Copyright (C) 1998, 2000 Radey Shouman 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. + +;;$Header: /home/ludo/src/guile/gitification/guile-cvs/guile/guile/guile-vm/module/slib/schmooz.scm,v 1.1 2001/04/14 11:24:46 kei Exp $ +;;$Name: $ + +;;; REPORT an error or warning +(define report + (lambda args + (display *scheme-source-name*) + (display ": In function `") + (display *procedure*) + (display "': ") + (newline) + + (display *derived-txi-name*) + (display ": ") + (display *output-line*) + (display ": warning: ") + (apply qreport args))) + +(define qreport + (lambda args + (for-each (lambda (x) (write x) (display #\ )) args) + (newline))) + +(require 'common-list-functions) ;some +(require 'string-search) +(require 'fluid-let) +(require 'line-i/o) ;read-line +(require 'filename) +(require 'scanf) +;;(require 'debug) (set! *qp-width* 100) (define qreport qpn) + +;;; This allows us to test without generating files +(define *scheme-source* (current-input-port)) +(define *scheme-source-name* "stdin") +(define *derived-txi* (current-output-port)) +(define *derived-txi-name* "?") + +(define *procedure* #f) +(define *output-line* 0) + +(define CONTLINE -80) + +;;; OUT indents and displays the arguments +(define (out indent . args) + (cond ((>= indent 0) + (newline *derived-txi*) + (set! *output-line* (+ 1 *output-line*)) + (do ((j indent (- j 8))) + ((> 8 j) + (do ((i j (- i 1))) + ((>= 0 i)) + (display #\ *derived-txi*))) + (display #\ *derived-txi*)))) + (for-each (lambda (a) + (cond ((symbol? a) + (display a *derived-txi*)) + ((string? a) + (display a *derived-txi*) +; (cond ((string-index a #\newline) +; (set! *output-line* (+ 1 *output-line*)) +; (report "newline in string" a))) + ) + (else + (display a *derived-txi*)))) + args)) + +;; LINE is a string, ISTRT the index in LINE at which to start. +;; Returns a list (next-char-number . list-of-tokens). +;; arguments look like: +;; "(arg1 arg2)" or "{arg1,arg2}" or the whole line is split +;; into whitespace separated tokens. +(define (parse-args line istrt) + (define (tok1 istrt close sep? splice) + (let loop-args ((istrt istrt) + (args '())) + (let loop ((iend istrt)) + (cond ((>= iend (string-length line)) + (if close + (slib:error close "not found in" line) + (cons iend + (reverse + (if (> iend istrt) + (cons (substring line istrt iend) args) + args))))) + ((eqv? close (string-ref line iend)) + (cons (+ iend 1) + (reverse (if (> iend istrt) + (cons (substring line istrt iend) args) + args)))) + ((sep? (string-ref line iend)) + (let ((arg (and (> iend istrt) + (substring line istrt iend)))) + (if (equal? arg splice) + (let ((rest (tok1 (+ iend 1) close sep? splice))) + (cons (car rest) + (append args (cadr rest)))) + (loop-args (+ iend 1) + (if arg + (cons arg args) + args))))) + (else + (loop (+ iend 1))))))) + (let skip ((istrt istrt)) + (cond ((>= istrt (string-length line)) (cons istrt '())) + ((char-whitespace? (string-ref line istrt)) + (skip (+ istrt 1))) + ((eqv? #\{ (string-ref line istrt)) + (tok1 (+ 1 istrt) #\} (lambda (c) (eqv? c #\,)) #f)) + ((eqv? #\( (string-ref line istrt)) + (tok1 (+ 1 istrt) #\) char-whitespace? ".")) + (else + (tok1 istrt #f char-whitespace? #f))))) + + +;; Substitute @ macros in string LINE. +;; Returns a list, the first element is the substituted version +;; of LINE, the rest are lists beginning with '@dfn or '@args +;; and followed by the arguments that were passed to those macros. +;; MACS is an alist of (macro-name . macro-value) pairs. +(define (substitute-macs line macs) + (define (get-word i) + (let loop ((j (+ i 1))) + (cond ((>= j (string-length line)) + (substring line i j)) + ((or (char-alphabetic? (string-ref line j)) + (char-numeric? (string-ref line j))) + (loop (+ j 1))) + (else (substring line i j))))) + (let loop ((istrt 0) + (i 0) + (res '())) + (cond ((>= i (string-length line)) + (list + (apply string-append + (reverse + (cons (substring line istrt (string-length line)) + res))))) + ((char=? #\@ (string-ref line i)) + (let* ((w (get-word i)) + (symw (string->symbol w))) + (cond ((eq? '@cname symw) + (let ((args (parse-args + line (+ i (string-length w))))) + (cond ((and args (= 2 (length args))) + (loop (car args) (car args) + (cons + (string-append + "@code{" (cadr args) "}") + (cons (substring line istrt i) res)))) + (else + (report "@cname wrong number of args" line) + (loop istrt (+ i (string-length w)) res))))) + ((eq? '@dfn symw) + (let* ((args (parse-args + line (+ i (string-length w)))) + (inxt (car args)) + (rest (loop inxt inxt + (cons (substring line istrt inxt) + res)))) + (cons (car rest) + (cons (cons '@dfn (cdr args)) + (cdr rest))))) + ((eq? '@args symw) + (let* ((args (parse-args + line (+ i (string-length w)))) + (inxt (car args)) + (rest (loop inxt inxt res))) + (cons (car rest) + (cons (cons '@args (cdr args)) + (cdr rest))))) + ((assq symw macs) => + (lambda (s) + (loop (+ i (string-length w)) + (+ i (string-length w)) + (cons (cdr s) + (cons (substring line istrt i) res))))) + (else (loop istrt (+ i (string-length w)) res))))) + (else (loop istrt (+ i 1) res))))) + + +(define (sexp-def sexp) + (and (pair? sexp) + (memq (car sexp) '(DEFINE DEFVAR DEFCONST DEFINE-SYNTAX DEFMACRO)) + (car sexp))) + +(define def->var-name cadr) + +(define (def->args sexp) + (define name (cadr sexp)) + (define (body forms) + (if (pair? forms) + (if (null? (cdr forms)) + (form (car forms)) + (body (cdr forms))) + #f)) + (define (form sexp) + (if (pair? sexp) + (case (car sexp) + ((LAMBDA) (cons name (cadr sexp))) + ((BEGIN) (body (cdr sexp))) + ((LET LET* LETREC) + (if (or (null? (cadr sexp)) + (pair? (cadr sexp))) + (body (cddr sexp)) + (body (cdddr sexp)))) ;named LET + (else #f)) + #f)) + (case (car sexp) + ((DEFINE) (if (pair? name) + name + (form (caddr sexp)))) + ((DEFINE-SYNTAX) '()) + ((DEFMACRO) (cons (cadr sexp) (caddr sexp))) + ((DEFVAR DEFCONST) #f) + (else (slib:error 'schmooz "doesn't look like definition" sexp)))) + +;; Generate alist of argument macro definitions. +;; If ARGS is a symbol or string, then the definitions will be used in a +;; `defvar', if ARGS is a (possibly improper) list, they will be used in +;; a `defun'. +(define (scheme-args->macros args) + (define (arg->string a) + (if (string? a) a (symbol->string a))) + (define (arg->macros arg i) + (let ((s (number->string i)) + (m (string-append "@var{" (arg->string arg) "}"))) + (list (cons (string->symbol (string-append "@" s)) m) + (cons (string->symbol (string-append "@arg" s)) m)))) + (let* ((fun? (pair? args)) + (arg0 (if fun? (car args) args)) + (args (if fun? (cdr args) '()))) + (let ((m0 (string-append + (if fun? "@code{" "@var{") (arg->string arg0) "}"))) + (append + (list (cons '@arg0 m0) (cons '@0 m0)) + (let recur ((i 1) + (args args)) + (cond ((null? args) '()) + ((or (symbol? args) ;Rest list + (string? args)) + (arg->macros args i)) + (else + (append (arg->macros (car args) i) + (recur (+ i 1) (cdr args)))))))))) + +;; Extra processing to be done for @dfn +(define (out-cindex arg) + (out 0 "@cindex " arg)) + +;; ARGS looks like the cadr of a function definition: +;; (fun-name arg1 arg2 ...) +(define (schmooz-fun defop args body xdefs) + (define (out-header args op) + (let ((fun (car args)) + (args (cdr args))) + (out 0 #\@ op #\space fun) + (let loop ((args args)) + (cond ((null? args)) + ((symbol? args) + (loop (symbol->string args))) + ((string? args) + (out CONTLINE " " + (let ((n (- (string-length args) 1))) + (if (eqv? #\s (string-ref args n)) + (substring args 0 n) + args)) + " @dots{}")) + ((pair? args) + (out CONTLINE " " + (if (or (eq? '... (car args)) + (equal? "..." (car args))) + "@dots{}" + (car args))) + (loop (cdr args))) + (else (slib:error 'schmooz-fun args)))))) + (let* ((mac-list (scheme-args->macros args)) + (ops (case defop + ((DEFINE-SYNTAX) '("defspec" . "defspecx")) + ((DEFMACRO) '("defmac" . "defmacx")) + (else '("defun" . "defunx"))))) + (out-header args (car ops)) + (let loop ((xdefs xdefs)) + (cond ((pair? xdefs) + (out-header (car xdefs) (cdr ops)) + (loop (cdr xdefs))))) + (for-each (lambda (subl) + (out 0 (car subl)) + (for-each (lambda (l) + (case (car l) + ((@dfn) + (out-cindex (cadr l))) + ((@args) + (out-header + (cons (car args) (cdr l)) + (cdr ops))))) + (cdr subl))) + (map (lambda (bl) + (substitute-macs bl mac-list)) + body)) + (out 0 "@end " (car ops)) + (out 0))) + +(define (schmooz-var defop name body xdefs) + (let* ((mac-list (scheme-args->macros name))) + (out 0 "@defvar " name) + (let loop ((xdefs xdefs)) + (cond ((pair? xdefs) + (out 0 "@defvarx " (car xdefs)) + (loop (cdr xdefs))))) + (for-each (lambda (subl) + (out 0 (car subl)) + (for-each (lambda (l) + (case (car l) + ((@dfn) (out-cindex (cadr l))) + (else + (report "bad macro" l)))) + (cdr subl))) + (map (lambda (bl) + (substitute-macs bl mac-list)) + body)) + (out 0 "@end defvar") + (out 0))) + +;;; SCHMOOZ files. +(define schmooz + (let* ((scheme-file? (filename:match-ci?? "*??scm")) + (txi-file? (filename:match-ci?? "*??txi")) + (texi-file? (let ((tex? (filename:match-ci?? "*??tex")) + (texi? (filename:match-ci?? "*??texi"))) + (lambda (filename) (or (txi-file? filename) + (tex? filename) + (texi? filename))))) + (txi->scm (filename:substitute?? "*txi" "*scm")) + (scm->txi (filename:substitute?? "*scm" "*txi"))) + (define (schmooz-texi-file file) + (call-with-input-file file + (lambda (port) + (do ((pos (find-string-from-port? "@include" port) + (find-string-from-port? "@include" port))) + ((not pos)) + (let ((fname #f)) + (cond ((not (eqv? 1 (fscanf port " %s" fname)))) + ((not (txi-file? fname))) + ((not (file-exists? (txi->scm fname)))) + (else (schmooz (txi->scm fname))))))))) + (define (schmooz-scm-file file txi-name) + (display "Schmoozing ") (write file) + (display " -> ") (write txi-name) (newline) + (fluid-let ((*scheme-source* (open-input-file file)) + (*scheme-source-name* file) + (*derived-txi* (open-output-file txi-name)) + (*derived-txi-name* txi-name)) + (set! *output-line* 1) + (cond ((scheme-file? file)) + (else (find-string-from-port? ";" *scheme-source* #\;) + (read-line *scheme-source*))) + (schmooz-tops schmooz-top) + (close-input-port *scheme-source*) + (close-output-port *derived-txi*))) + (lambda files + (for-each (lambda (file) + (define sl (string-length file)) + (cond ((texi-file? file) (schmooz-texi-file file)) + ((scheme-file? file) + (schmooz-scm-file file (scm->txi file))) + (else (schmooz-scm-file + file (string-append file ".txi"))))) + files)))) + +;;; SCHMOOZ-TOPS - schmooz top level forms. +(define (schmooz-tops schmooz-top) + (let ((doc-lines '()) + (doc-args #f)) + (define (skip-ws line istrt) + (do ((i istrt (+ i 1))) + ((or (>= i (string-length line)) + (not (memv (string-ref line i) + '(#\space #\tab #\;)))) + (substring line i (string-length line))))) + + (define (tok1 line) + (let loop ((i 0)) + (cond ((>= i (string-length line)) line) + ((or (char-whitespace? (string-ref line i)) + (memv (string-ref line i) '(#\; #\( #\{))) + (substring line 0 i)) + (else (loop (+ i 1)))))) + + (define (read-cmt-line) + (cond ((eqv? #\; (peek-char *scheme-source*)) + (read-char *scheme-source*) + (read-cmt-line)) + (else (read-line *scheme-source*)))) + + (define (read-meta-cmt) + (let skip ((metarg? #f)) + (let ((c (read-char *scheme-source*))) + (case c + ((#\newline) (if metarg? (skip #t))) + ((#\\) (skip #t)) + ((#\!) (cond ((eqv? #\# (peek-char *scheme-source*)) + (read-char *scheme-source*) + (if #f #f)) + (else + (skip metarg?)))) + (else + (if (char? c) (skip metarg?) c)))))) + + (define (lp c) + (cond ((eof-object? c) + (cond ((pair? doc-lines) + (report "No definition found for @body doc lines" + (reverse doc-lines))))) + ((eqv? c #\newline) + (read-char *scheme-source*) + (set! *output-line* (+ 1 *output-line*)) + ;;(newline *derived-txi*) + (lp (peek-char *scheme-source*))) + ((char-whitespace? c) + (write-char (read-char *scheme-source*) *derived-txi*) + (lp (peek-char *scheme-source*))) + ((char=? c #\;) + (c-cmt c)) + ((char=? c #\#) + (read-char *scheme-source*) + (if (eqv? #\! (peek-char *scheme-source*)) + (read-meta-cmt) + (report "misread sharp object" (peek-char *scheme-source*))) + (lp (peek-char *scheme-source*))) + (else + (sx)))) + + (define (sx) + (let* ((s1 (read *scheme-source*)) + ;;Read all forms separated only by single newlines + ;;and trailing whitespace. + (ss (let recur () + (let ((c (peek-char *scheme-source*))) + (cond ((eqv? c #\newline) + (read-char *scheme-source*) + (if (eqv? #\( (peek-char *scheme-source*)) + (let ((s (read *scheme-source*))) + (cons s (recur))) + '())) + ((char-whitespace? c) + (read-char *scheme-source*) + (recur)) + (else '())))))) + (cond ((eof-object? s1)) + (else + (schmooz-top s1 ss (reverse doc-lines) doc-args) + (set! doc-lines '()) + (set! doc-args #f) + (lp (peek-char *scheme-source*)))))) + + (define (out-cmt line) + (let ((subl (substitute-macs line '()))) + (display (car subl) *derived-txi*) + (for-each + (lambda (l) + (case (car l) + ((@dfn) + (out-cindex (cadr l))) + (else + (report "bad macro" line)))) + (cdr subl)) + (newline *derived-txi*))) + + ;;Comments not transcribed to generated Texinfo files. + (define (c-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (read-char *scheme-source*) + (c-cmt (peek-char *scheme-source*))) + ;; Escape to start Texinfo comments + ((eqv? #\@ c) + (let* ((line (read-line *scheme-source*)) + (tok (tok1 line))) + (cond ((or (string=? tok "@body") + (string=? tok "@text")) + (set! doc-lines + (cons (skip-ws line (string-length tok)) + doc-lines)) + (body-cmt (peek-char *scheme-source*))) + ((string=? tok "@args") + (let ((args + (parse-args line (string-length tok)))) + (set! doc-args (cdr args)) + (set! doc-lines + (cons (skip-ws line (car args)) + doc-lines))) + (body-cmt (peek-char *scheme-source*))) + (else + (out-cmt (if (string=? tok "@") + (skip-ws line 1) + line)) + (doc-cmt (peek-char *scheme-source*)))))) + ;; Transcribe the comment line to C source file. + (else + (read-line *scheme-source*) + (lp (peek-char *scheme-source*))))) + + ;;Comments incorporated in generated Texinfo files. + ;;Continue adding lines to DOC-LINES until a non-comment + ;;line is reached (may be a blank line). + (define (body-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (set! doc-lines (cons (read-cmt-line) doc-lines)) + (body-cmt (peek-char *scheme-source*))) + ((eqv? c #\newline) + (read-char *scheme-source*) + (lp (peek-char *scheme-source*))) + ;; Allow whitespace before ; in doc comments. + ((char-whitespace? c) + (read-char *scheme-source*) + (body-cmt (peek-char *scheme-source*))) + (else + (lp (peek-char *scheme-source*))))) + + ;;Comments incorporated in generated Texinfo files. + ;;Transcribe comments to current position in Texinfo file + ;;until a non-comment line is reached (may be a blank line). + (define (doc-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (out-cmt (read-cmt-line)) + (doc-cmt (peek-char *scheme-source*))) + ((eqv? c #\newline) + (read-char *scheme-source*) + (newline *derived-txi*) + (lp (peek-char *scheme-source*))) + ;; Allow whitespace before ; in doc comments. + ((char-whitespace? c) + (read-char *scheme-source*) + (doc-cmt (peek-char *scheme-source*))) + (else + (newline *derived-txi*) + (lp (peek-char *scheme-source*))))) + (lp (peek-char *scheme-source*)))) + +(define (schmooz-top-doc-begin def1 defs doc proc-args) + (let ((op1 (sexp-def def1))) + (cond + ((not op1) + (or (null? doc) + (report "SCHMOOZ: no definition found for Texinfo documentation" + doc (car defs)))) + (else + (let* ((args (def->args def1)) + (args (if proc-args + (cons (if args (car args) (def->var-name def1)) + proc-args) + args))) + (let loop ((ss defs) + (smatch (list (or args (def->var-name def1))))) + (if (null? ss) + (let ((smatch (reverse smatch))) + ((if args schmooz-fun schmooz-var) + op1 (car smatch) doc (cdr smatch))) + (if (eq? op1 (sexp-def (car ss))) + (let ((a (def->args (car ss)))) + (loop (cdr ss) + (if args + (if a + (cons a smatch) + smatch) + (if a + smatch + (cons (def->var-name (car ss)) + smatch))))))))))))) + +;;; SCHMOOZ-TOP - schmooz top level form sexp. +(define (schmooz-top sexp1 sexps doc proc-args) + (cond ((not (pair? sexp1))) + ((pair? sexps) + (if (pair? doc) + (schmooz-top-doc-begin sexp1 sexps doc proc-args)) + (set! doc '())) + (else + (case (car sexp1) + ((LOAD REQUIRE) ;If you redefine load, you lose + #f) + ((BEGIN) + (schmooz-top (cadr sexp1) '() doc proc-args) + (set! doc '()) + (for-each (lambda (s) + (schmooz-top s '() doc #f)) + (cddr sexp1))) + ((DEFVAR DEFINE DEFCONST DEFINE-SYNTAX DEFMACRO) + (let* ((args (def->args sexp1)) + (args (if proc-args + (cons (if args (car args) (cadr sexp1)) + proc-args) + args))) + (cond (args + (set! *procedure* (car args)) + (cond ((pair? doc) + (schmooz-fun (car sexp1) args doc '()) + (set! doc '())))) + (else + (cond ((pair? doc) + (schmooz-var (car sexp1) (cadr sexp1) doc '()) + (set! doc '())))))))))) + (or (null? doc) + (report + "SCHMOOZ: no definition found for Texinfo documentation" + doc sexp)) + (set! *procedure* #f)) diff --git a/module/slib/schmooz.texi b/module/slib/schmooz.texi new file mode 100644 index 000000000..24c30d0f1 --- /dev/null +++ b/module/slib/schmooz.texi @@ -0,0 +1,104 @@ + +@cindex schmooz +@dfn{Schmooz} is a simple, lightweight markup language for interspersing +Texinfo documentation with Scheme source code. Schmooz does not create +the top level Texinfo file; it creates @samp{txi} files which can be +imported into the documentation using the Texinfo command +@samp{@@include}. + +@ftindex schmooz +@code{(require 'schmooz)} defines the function @code{schmooz}, which is +used to process files. Files containing schmooz documentation should +not contain @code{(require 'schmooz)}. + +@deffn Procedure schmooz filename@r{scm} @dots{} +@var{Filename}scm should be a string ending with @samp{scm} naming an +existing file containing Scheme source code. @code{schmooz} extracts +top-level comments containing schmooz commands from @var{filename}scm +and writes the converted Texinfo source to a file named +@var{filename}txi. + +@deffnx Procedure schmooz filename@r{texi} @dots{} +@deffnx Procedure schmooz filename@r{tex} @dots{} +@deffnx Procedure schmooz filename@r{txi} @dots{} +@var{Filename} should be a string naming an existing file containing +Texinfo source code. For every occurrence of the string @samp{@@include +@var{filename}txi} within that file, @code{schmooz} calls itself with +the argument @samp{@var{filename}scm}. +@end deffn + +Schmooz comments are distinguished (from non-schmooz comments) by their +first line, which must start with an at-sign (@@) preceded by one or +more semicolons (@t{;}). A schmooz comment ends at the first subsequent +line which does @emph{not} start with a semicolon. Currently schmooz +comments are recognized only at top level. + +Schmooz comments are copied to the Texinfo output file with the leading +contiguous semicolons removed. Certain character sequences starting +with at-sign are treated specially. Others are copied unchanged. + +A schmooz comment starting with @samp{@@body} must be followed by a +Scheme definition. All comments between the @samp{@@body} line and +the definition will be included in a Texinfo definition, either +a @samp{@@defun} or a @samp{@@defvar}, depending on whether a procedure +or a variable is being defined. + +Within the text of that schmooz comment, at-sign +followed by @samp{0} will be replaced by @code{@@code@{procedure-name@}} +if the following definition is of a procedure; or +@code{@@var@{variable@}} if defining a variable. + +An at-sign followed by a non-zero digit will expand to the variable +citation of that numbered argument: @samp{@@var@{argument-name@}}. + +If more than one definition follows a @samp{@@body} comment line +without an intervening blank or comment line, then those definitions +will be included in the same Texinfo definition using @samp{@@defvarx} +or @samp{@@defunx}, depending on whether the first definition is of +a variable or of a procedure. + +Schmooz can figure out whether a definition is of a procedure if +it is of the form: + +@samp{(define (<identifier> <arg> ...) <expression>)} + +@noindent +or if the left hand side of the definition is some form ending in +a lambda expression. Obviously, it can be fooled. In order to +force recognition of a procedure definition, start the documentation +with @samp{@@args} instead of @samp{@@body}. @samp{@@args} should +be followed by the argument list of the function being defined, +which may be enclosed in parentheses and delimited by whitespace, +(as in Scheme), enclosed in braces and separated by commas, (as +in Texinfo), or consist of the remainder of the line, separated +by whitespace. + +For example: + +@example +;;@@args arg1 args ... +;;@@0 takes argument @@1 and any number of @@2 +(define myfun (some-function-returning-magic)) +@end example + +Will result in: + +@example +@@defun myfun arg1 args @@dots@{@} + +@@code@{myfun@} takes argument @@var@{arg1@} and any number of @@var@{args@} +@@end defun +@end example + +@samp{@@args} may also be useful for indicating optional arguments +by name. If @samp{@@args} occurs inside a schmooz comment section, +rather than at the beginning, then it will generate a @samp{@@defunx} +line with the arguments supplied. + + +If the first at-sign in a schmooz comment is immediately followed by +whitespace, then the comment will be expanded to whatever follows that +whitespace. If the at-sign is followed by a non-whitespace character +then the at-sign will be included as the first character of the expansion. +This feature is intended to make it easy to include Texinfo directives +in schmooz comments. diff --git a/module/slib/scm.init b/module/slib/scm.init new file mode 100644 index 000000000..39092b6a9 --- /dev/null +++ b/module/slib/scm.init @@ -0,0 +1,6 @@ +;"scm.init" Configuration file for SLIB for SCM -*-scheme-*- + +;;; SCM supports SLIB natively; no initialization file is actually +;;; required. So just stub this file: + +(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/module/slib/scmacro.scm b/module/slib/scmacro.scm new file mode 100644 index 000000000..47bafcab9 --- /dev/null +++ b/module/slib/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/module/slib/scmactst.scm b/module/slib/scmactst.scm new file mode 100644 index 000000000..3b71341a0 --- /dev/null +++ b/module/slib/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/module/slib/scsh.init b/module/slib/scsh.init new file mode 100644 index 000000000..39e6fecf7 --- /dev/null +++ b/module/slib/scsh.init @@ -0,0 +1,284 @@ +;;; "scsh.init" Initialisation for SLIB for Scsh 0.5.1 -*-scheme-*- +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. + +;;; (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) 'Scsh) + +;;; (scheme-implementation-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) + "http://swissnet.ai.mit.edu/ftpdir/scsh/") + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "0.5.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) + "/home/tomas/src/scsh-0.5.1/") + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +(define (library-vicinity) + "/home/tomas/src/slib2b1/") + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define home-vicinity + (let ((home-path (getenv "HOME"))) + (lambda () home-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 ;proposed 2-arugment 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 error-output-port) + +;;; (TMPNAM) makes a temporary file name. +(define (tmpnam) + (create-temp-file "slib_")) + +;;; (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. + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; 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) + +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. + +; [s48 has two argument eval] +(define (slib:eval 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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;;; define an error procedure for the library +(define (slib:error . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (apply error args)) + +;;; define these as appropriate for your system. +(define slib:tab (ascii->char 9)) +(define slib:form-feed (ascii->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 append! append) + +;;; 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) + +;;; Scheme48 complains that these are not defined (even though they +;;; won't be called until they are). +(define synclo:load #f) +(define syncase:load #f) +(define macwork:load #f) +(define transcript-on #f) +(define transcript-off #f) + +(define array? #f) +(define record? #f) +(define sort! #f) + +(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/module/slib/selfset.scm b/module/slib/selfset.scm new file mode 100644 index 000000000..14fcd20fd --- /dev/null +++ b/module/slib/selfset.scm @@ -0,0 +1,28 @@ +;;"selfset.scm" Set single letter identifiers to their symbols. + + (define a 'a) + (define b 'b) + (define c 'c) + (define d 'd) + (define e 'e) + (define f 'f) + (define g 'g) + (define h 'h) + (define i 'i) + (define j 'j) + (define k 'k) + (define l 'l) + (define m 'm) + (define n 'n) + (define o 'o) + (define p 'p) + (define q 'q) + (define r 'r) + (define s 's) + (define t 't) + (define u 'u) + (define v 'v) + (define w 'w) + (define x 'x) + (define y 'y) + (define z 'z) diff --git a/module/slib/sierpinski.scm b/module/slib/sierpinski.scm new file mode 100644 index 000000000..6300e8abd --- /dev/null +++ b/module/slib/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/module/slib/simetrix.scm b/module/slib/simetrix.scm new file mode 100644 index 000000000..aa9a29dd5 --- /dev/null +++ b/module/slib/simetrix.scm @@ -0,0 +1,246 @@ +;;;; "simetrix.scm" SI Metric Interchange Format for Scheme +;;; Copyright (C) 2000, 2001 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. + +;; Implements "Representation of numerical values and SI units in +;; character strings for information interchanges" +;; http://swissnet.ai.mit.edu/~jaffer/MIXF.html + +(require 'precedence-parse) + +;;; Combine alists +(define (SI:adjoin unitlst SIms) + (for-each (lambda (new) + (define pair (assoc (car new) SIms)) + (if pair + (set-cdr! pair (+ (cdr new) (cdr pair))) + (set! SIms (cons (cons (car new) (cdr new)) SIms)))) + unitlst) + SIms) + +;;; Combine unit-alists +(define (SI:product unit1 unit2) + (define nunits '()) + (set! unit1 (SI:expand-unit unit1)) + (set! unit2 (SI:expand-unit unit2)) + (cond ((and unit1 unit2) + (set! nunits (SI:adjoin unit1 nunits)) + (set! nunits (SI:adjoin unit2 nunits)) + nunits) + (else #f))) + +(define (SI:quotient unit1 . units) + (apply SI:product unit1 + (map (lambda (unit) (SI:pow unit -1)) units))) + +(define (SI:pow unit expon) + (define punit (SI:expand-unit unit)) + (and punit (number? expon) + (map (lambda (unit-pair) + (cons (car unit-pair) (* (cdr unit-pair) expon))) + punit))) + +;;; Parse helper functions. +(define (SI:solidus . args) + (if (and (= 2 (length args)) + (number? (car args)) + (number? (cadr args))) + (/ (car args) (cadr args)) + (apply SI:quotient args))) + +(define (SI:e arg1 arg2) + (cond ((and (number? arg1) (number? arg2) + (exact? arg2)) + (let ((expo (string->number + (string-append "1e" (number->string arg2))))) + (and expo (* arg1 expo)))) + (else (SI:product arg1 arg2)))) + +(define (SI:dot arg1 arg2) + (cond ((and (number? arg1) (number? arg2) + (exact? arg1) (exact? arg2) + (positive? arg2)) + (string->number + (string-append (number->string arg1) "." (number->string arg2)))) + (else (SI:product arg1 arg2)))) + +(define (SI:minus arg) (and (number? arg) (- arg))) + +(define (SI:identity . args) (and (= 1 (length args)) (car args))) + +;;; Binary prefixes are (zero? (modulo expo 10)) +(define SI:prefix-exponents + '(("Y" 24) ("Z" 21) ("E" 18) ("P" 15) + ("T" 12) ("G" 9) ("M" 6) ("k" 3) ("h" 2) ("da" 1) + ("d" -1) ("c" -2) ("m" -3) ("u" -6) ("n" -9) + ("p" -12) ("f" -15) ("a" -18) ("z" -21) ("y" -24) + + ("Ei" 60) ("Pi" 50) ("Ti" 40) ("Gi" 30) ("Mi" 20) ("Ki" 10) + )) + +(define SI:unit-infos + `( + ("s" all #f) + ("min" none "60.s") + ("h" none "3600.s") + ("d" none "86400.s") + ("Hz" all "s^-1") + ("Bd" pos "s^-1") + ("m" all #f) + ("L" neg "dm^3") + ("rad" neg #f) + ("sr" neg "rad^2") + ("r" pos ,(string-append (number->string (* 8 (atan 1))) ".rad")) + ("o" neg ,(string-append (number->string (/ 360)) ".r")) + ("bit" bin #f) + ("B" pin "8.b") + ("g" all #f) + ("t" pos "Mg") + ("u" none "1.66053873e-27.kg") + ("mol" all #f) + ("kat" all "mol/s") + ("K" all #f) + ("oC" neg #f) + ("cd" all #f) + ("lm" all "cd.sr") + ("lx" all "lm/m^2") + ("N" all "m.kg/s^2") + ("Pa" all "N/m^2") + ("J" all "N.m") + ("eV" all "1.602176462e-19.J") + ("W" all "J/s") + ("Np" neg #f) + ("dB" none ,(string-append (number->string (/ (log 10) 20)) ".Np")) + ("A" all #f) + ("C" all "A.s") + ("V" all "W/A") + ("F" all "C/V") + ("Ohm" all "V/A") + ("S" all "A/V") + ("Wb" all "V.s") + ("T" all "Wb/m^2") + ("H" all "Wb/A") + ("Bq" all "s^-1") + ("Gy" all "m^2.s^-2") + ("Sv" all "m^2.s^-2") + )) + +(define (SI:try-split preSI SIm) + (define expo (assoc preSI SI:prefix-exponents)) + (define stuff (assoc SIm SI:unit-infos)) + (if expo (set! expo (cadr expo))) + (if stuff (set! stuff (cdr stuff))) + (and expo stuff + (let ((equivalence (cadr stuff))) + (and (case (car stuff) ;restriction + ((all) (not (zero? (modulo expo 10)))) + ((pos) (and (positive? expo) (not (zero? (modulo expo 10))))) + ((bin) #t) + ((pin) (positive? expo)) + ((neg) (and (negative? expo) (not (zero? (modulo expo 10))))) + ((none) #f) + (else #f)) + (if (and (positive? expo) (zero? (modulo expo 10))) + (if equivalence + (let ((eqv (SI:expand-equivalence equivalence))) + (and eqv + (SI:adjoin (list (cons 1024 (quotient expo 10))) + eqv))) + (list (cons 1024 (quotient expo 10)) + (cons SIm 1))) + (if equivalence + (let ((eqv (SI:expand-equivalence equivalence))) + (and eqv (SI:adjoin (list (cons 10 expo)) eqv))) + (list (cons 10 expo) (cons SIm 1)))))))) + +(define (SI:try-simple SIm) + (define stuff (assoc SIm SI:unit-infos)) + (if stuff (set! stuff (cdr stuff))) + (and stuff (if (cadr stuff) + (SI:expand-equivalence (cadr stuff)) + (list (cons SIm 1))))) + +(define (SI:expand-unit str) + (if (symbol? str) (set! str (symbol->string str))) + (cond + ((pair? str) str) + ((number? str) (list (cons str 1))) + ((string? str) + (let ((len (string-length str))) + (let ((s1 (and (> len 1) + (SI:try-split (substring str 0 1) (substring str 1 len)))) + (s2 (and (> len 2) + (SI:try-split (substring str 0 2) (substring str 2 len)))) + (sn (and (SI:try-simple str)))) + (define cnt (+ (if s1 1 0) (if s2 1 0) (if sn 1 0))) + (if (> cnt 1) (slib:warn 'ambiguous s1 s2 sn)) + (or s1 s2 sn)))) + (else #f))) + +(define (SI:expand-equivalence str) + (call-with-input-string + str (lambda (sport) + (define result (prec:parse SI:grammar 'EOS sport)) + (cond ((eof-object? result) (list (cons 1 0))) + ((symbol? result) (SI:expand-unit result)) + (else result))))) + +;;;; advertised interface +(define (SI:conversion-factor to-unit from-unit) + (let ((funit (SI:expand-equivalence from-unit)) + (tunit (SI:expand-equivalence to-unit))) + (if (and funit tunit) + (let loop ((unit-pairs (SI:quotient funit tunit)) + (flactor 1)) + (cond ((null? unit-pairs) flactor) + ((zero? (round (* 2 (cdar unit-pairs)))) + (loop (cdr unit-pairs) flactor)) + ((number? (caar unit-pairs)) + (loop (cdr unit-pairs) + ((if (negative? (cdar unit-pairs)) / *) + flactor + (expt (caar unit-pairs) + (abs (cdar unit-pairs)))))) + (else 0))) + (+ (if tunit 0 -1) (if funit 0 -2))))) + +(define SI:grammar #f) + +;;;; The parse tables. +;;; Definitions accumulate in top-level variable *SYN-DEFS*. +;;(trace-all (in-vicinity (program-vicinity) "simetrix.scm")) + +;;; Character classes +(prec:define-grammar (tok:char-group 70 #\^ list->string)) +(prec:define-grammar (tok:char-group 49 #\. list->string)) +(prec:define-grammar (tok:char-group 50 #\/ list->string)) +(prec:define-grammar (tok:char-group 51 #\- list->string)) +(prec:define-grammar (tok:char-group 40 tok:decimal-digits + (lambda (l) (string->number (list->string l))))) +(prec:define-grammar (tok:char-group 44 + (string-append tok:upper-case tok:lower-case "@_") + list->string)) + +(prec:define-grammar (prec:prefix '- SI:minus 130)) +(prec:define-grammar (prec:infix "." SI:dot 120 120)) +(prec:define-grammar (prec:infix '("e" "E") SI:e 115 125)) +(prec:define-grammar (prec:infix '/ SI:solidus 100 150)) +(prec:define-grammar (prec:infix '^ SI:pow 160 140)) +(prec:define-grammar (prec:matchfix #\( SI:identity #f #\))) + +(set! SI:grammar *syn-defs*) diff --git a/module/slib/slib.info b/module/slib/slib.info new file mode 100644 index 000000000..0b481552e --- /dev/null +++ b/module/slib/slib.info @@ -0,0 +1,12187 @@ +This is slib.info, produced by makeinfo version 4.0 from slib.texi. + +INFO-DIR-SECTION The Algorithmic Language Scheme +START-INFO-DIR-ENTRY +* SLIB: (slib). Scheme Library +END-INFO-DIR-ENTRY + + This file documents SLIB, the portable Scheme library. + + Copyright (C) 1993 Todd R. Eigenschink +Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000 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: The Library System, Prev: (dir), Up: (dir) + +"SLIB" is a portable library for the programming language "Scheme". It +provides a platform independent framework for using "packages" of +Scheme procedures and syntax. As distributed, SLIB contains useful +packages for all Scheme implementations. Its catalog can be +transparently extended to accomodate packages specific to a site, +implementation, user, or directory. + +* Menu: + +* The Library System:: How to use and customize. +* Scheme Syntax Extension Packages:: +* Textual Conversion Packages:: +* Mathematical Packages:: +* Database Packages:: +* Other Packages:: +* About SLIB:: Install, etc. +* Index:: + + +File: slib.info, Node: The Library System, Next: Scheme Syntax Extension Packages, Prev: Top, Up: Top + +The Library System +****************** + +* Menu: + +* Feature:: SLIB names. +* Requesting Features:: +* Library Catalogs:: +* Catalog Compilation:: +* Built-in Support:: +* About this manual:: + + +File: slib.info, Node: Feature, Next: Requesting Features, Prev: The Library System, Up: The Library System + +Feature +======= + +SLIB denotes "features" by symbols. SLIB maintains a list of features +supported by the Scheme "session". The set of features provided by a +session may change over time. Some features are properties of the +Scheme implementation being used. The following features detail what +sort of numbers are available from an implementation. + + * 'inexact + + * 'rational + + * 'real + + * 'complex + + * 'bignum + +Other features correspond to the presence of sets of Scheme procedures +or syntax (macros). + + - Function: provided? feature + Returns `#t' if FEATURE is supported by the current Scheme session. + + - Procedure: provide feature + Informs SLIB that FEATURE is supported. Henceforth `(provided? + FEATURE)' will return `#t'. + + (provided? 'foo) => #f + (provide 'foo) + (provided? 'foo) => #t + + +File: slib.info, Node: Requesting Features, Next: Library Catalogs, Prev: Feature, Up: The Library System + +Requesting Features +=================== + +SLIB creates and maintains a "catalog" mapping features to locations of +files introducing procedures and syntax denoted by those features. + +At the beginning of each section of this manual, there is a line like +`(require 'FEATURE)'. The Scheme files comprising SLIB are cataloged +so that these feature names map to the corresponding files. + +SLIB provides a form, `require', which loads the files providing the +requested feature. + + - Procedure: require feature + * If `(provided? FEATURE)' is true, then `require' just returns + an unspecified value. + + * Otherwise, if FEATURE is found in the catalog, then the + corresponding files will be loaded and an unspecified value + returned. + + Subsequently `(provided? FEATURE)' will return `#t'. + + * Otherwise (FEATURE not found in the catalog), an error is + signaled. + +The catalog can also be queried using `require:feature->path'. + + - Function: require:feature->path feature + * If FEATURE is already provided, then returns `#t'. + + * Otherwise, if FEATURE is in the catalog, the path or list of + paths associated with FEATURE is returned. + + * Otherwise, returns `#f'. + + +File: slib.info, Node: Library Catalogs, Next: Catalog Compilation, Prev: Requesting Features, Up: The Library System + +Library Catalogs +================ + +At the start of a session no catalog is present, but is created with the +first catalog inquiry (such as `(require 'random)'). Several sources +of catalog information are combined to produce the catalog: + + * standard SLIB packages. + + * additional packages of interest to this site. + + * packages specifically for the variety of Scheme which this session + is running. + + * packages this user wants to always have available. This catalog + is the file `homecat' in the user's "HOME" directory. + + * packages germane to working in this (current working) directory. + This catalog is the file `usercat' in the directory to which it + applies. One would typically `cd' to this directory before + starting the Scheme session. + +Catalog files consist of one or more "association list"s. In the +circumstance where a feature symbol appears in more than one list, the +latter list's association is retrieved. Here are the supported formats +for elements of catalog lists: + +`(FEATURE . <symbol>)' + Redirects to the feature named <symbol>. + +`(FEATURE . "<path>")' + Loads file <path>. + +`(FEATURE source "<path>")' + `slib:load's the Scheme source file <path>. + +`(FEATURE compiled "<path>" ...)' + `slib:load-compiled's the files <path> .... + +The various macro styles first `require' the named macro package, then +just load <path> or load-and-macro-expand <path> as appropriate for the +implementation. + +`(FEATURE defmacro "<path>")' + `defmacro:load's the Scheme source file <path>. + +`(FEATURE macro-by-example "<path>")' + `defmacro:load's the Scheme source file <path>. + +`(FEATURE macro "<path>")' + `macro:load's the Scheme source file <path>. + +`(FEATURE macros-that-work "<path>")' + `macro:load's the Scheme source file <path>. + +`(FEATURE syntax-case "<path>")' + `macro:load's the Scheme source file <path>. + +`(FEATURE syntactic-closures "<path>")' + `macro:load's the Scheme source file <path>. + +Here is an example of a `usercat' catalog. A Program in this directory +can invoke the `run' feature with `(require 'run)'. + + ;;; "usercat": SLIB catalog additions for SIMSYNCH. -*-scheme-*- + + ( + (simsynch . "../synch/simsynch.scm") + (run . "../synch/run.scm") + (schlep . "schlep.scm") + ) + + +File: slib.info, Node: Catalog Compilation, Next: Built-in Support, Prev: Library Catalogs, Up: The Library System + +Catalog Compilation +=================== + +SLIB combines the catalog information which doesn't vary per user into +the file `slibcat' in the implementation-vicinity. Therefore `slibcat' +needs change only when new software is installed or compiled. Because +the actual pathnames of files can differ from installation to +installation, SLIB builds a separate catalog for each implementation it +is used with. + +The definition of `*SLIB-VERSION*' in SLIB file `require.scm' is +checked against the catalog association of `*SLIB-VERSION*' to +ascertain when versions have changed. I recommend that the definition +of `*SLIB-VERSION*' be changed whenever the library is changed. If +multiple implementations of Scheme use SLIB, remember that recompiling +one `slibcat' will fix only that implementation's catalog. + +The compilation scripts of Scheme implementations which work with SLIB +can automatically trigger catalog compilation by deleting `slibcat' or +by invoking a special form of `require': + + - Procedure: require 'new-catalog + This will load `mklibcat', which compiles and writes a new + `slibcat'. + +Another special form of `require' erases SLIB's catalog, forcing it to +be reloaded the next time the catalog is queried. + + - Procedure: require #f + Removes SLIB's catalog information. This should be done before + saving an executable image so that, when restored, its catalog + will be loaded afresh. + +Each file in the table below is descibed in terms of its file-system +independent "vicinity" (*note Vicinity::). The entries of a catalog in +the table override those of catalogs above it in the table. + +`implementation-vicinity' `slibcat' + This file contains the associations for the packages comprising + SLIB, the `implcat' and the `sitecat's. The associations in the + other catalogs override those of the standard catalog. + +`library-vicinity' `mklibcat.scm' + creates `slibcat'. + +`library-vicinity' `sitecat' + This file contains the associations specific to an SLIB + installation. + +`implementation-vicinity' `implcat' + This file contains the associations specific to an implementation + of Scheme. Different implementations of Scheme should have + different `implementation-vicinity'. + +`implementation-vicinity' `mkimpcat.scm' + if present, creates `implcat'. + +`implementation-vicinity' `sitecat' + This file contains the associations specific to a Scheme + implementation installation. + +`home-vicinity' `homecat' + This file contains the associations specific to an SLIB user. + +`user-vicinity' `usercat' + This file contains associations effecting only those sessions whose + "working directory" is `user-vicinity'. + + +File: slib.info, Node: Built-in Support, Next: About this manual, Prev: Catalog Compilation, Up: The Library System + +Built-in Support +================ + +The procedures described in these sections are supported by all +implementations as part of the `*.init' files or by `require.scm'. + +* Menu: + +* 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: Require, Next: Vicinity, Prev: Built-in Support, Up: Built-in Support + +Require +------- + + - Variable: *features* + Is a list of symbols denoting features supported in this + implementation. *FEATURES* can grow as modules are `require'd. + *FEATURES* must be defined by all implementations (*note + Porting::). + + Here are features which SLIB (`require.scm') adds to *FEATURES* + when appropriate. + + * 'inexact + + * 'rational + + * 'real + + * 'complex + + * 'bignum + + For each item, `(provided? 'FEATURE)' will return `#t' if that + feature is available, and `#f' if not. + + - 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 functions if the argument 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 + FEATURE is a symbol. If `(provided? FEATURE)' is true `require' + returns. Otherwise, if `(assq FEATURE *catalog*)' is not `#f', + the associated files will be loaded and `(provided? FEATURE)' will + henceforth return `#t'. An unspecified value is returned. If + FEATURE is not found in `*catalog*', then an error is signaled. + + - Procedure: require pathname + PATHNAME is a string. If PATHNAME has not already been given as + an argument to `require', PATHNAME is loaded. An unspecified + value is returned. + + - 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*. + + +File: slib.info, Node: Vicinity, Next: Configuration, Prev: Require, Up: Built-in 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 path + Returns the vicinity of PATH 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 incorrect 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: home-vicinity + Returns the vicinity of the user's "HOME" directory, the directory + which typically contains files which customize a computer + environment for a user. If scheme is running without a user (eg. + a daemon) or if this concept is meaningless for the platform, then + `home-vicinity' returns `#f'. + + - 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: Built-in 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 + In implementations which support integers of practically unlimited + size, MOST-POSITIVE-FIXNUM is a large exact integer within the + range of exact integers that may result from computing the length + of a list, vector, or string. + + In implementations which do not support integers of practically + unlimited size, MOST-POSITIVE-FIXNUM is the largest exact integer + that may result from computing the length of a list, vector, or + string. + + - 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 "2d1" on scm "5b1" 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 "2d1" on scm "5b1" on unix | + (implementation-vicinity) is "/home/jaffer/scm/" + (library-vicinity) is "/home/jaffer/slib/" + (scheme-file-suffix) is ".scm" + loaded *features* : + trace alist qp sort + common-list-functions macro values getopt + compiled + implementation *features* : + bignum complex real rational + inexact vicinity ed getenv + tmpnam 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 current-time record + rev3-procedures rev2-procedures sun-dl string-case + array dump char-ready? full-continuation + system + implementation *catalog* : + (i/o-extensions compiled "/home/jaffer/scm/ioext.so") + ... + + +File: slib.info, Node: Input/Output, Next: Legacy, Prev: Configuration, Up: Built-in 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: Built-in Support + +Legacy +------ + + These procedures are provided by all implementations. + + - Function: identity x + IDENTITY returns its argument. + + Example: + (identity 3) + => 3 + (identity '(foo bar)) + => (foo bar) + (map identity LST) + == (copy-list LST) + +The following procedures were present in Scheme until R4RS (*note +Language changes: (r4rs)Notes.). They are provided by all SLIB +implementations. + + - 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: Built-in 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. *Note Eval:: provides a more general evaluation + facility. + + - 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:warn arg1 arg2 ... + Outputs a warning message containing the arguments. + + - 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: About this manual, Prev: Built-in Support, Up: The Library System + +About this manual +================= + + * Entries that are labeled as Functions are called for their return + values. Entries that are labeled as Procedures are called + primarily for their side effects. + + * Examples in this text were produced using the `scm' Scheme + implementation. + + * At the beginning of each section, there is a line that looks like + `(require 'feature)'. Include this line in your code prior to + using the package. + + +File: slib.info, Node: Scheme Syntax Extension Packages, Next: Textual Conversion Packages, Prev: The Library System, Up: Top + +Scheme Syntax Extension Packages +******************************** + +* 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: Scheme Syntax Extension Packages, Up: Scheme Syntax Extension Packages + +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 + `defmacro' 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: Scheme Syntax Extension Packages + +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: Scheme Syntax Extension Packages + +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: Scheme Syntax Extension Packages + +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. + + +File: slib.info, Node: Syntactic Closures, Next: Syntax-Case Macros, Prev: Macros That Work, Up: Scheme Syntax Extension Packages + +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: Scheme Syntax Extension Packages + +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: Scheme Syntax Extension Packages + +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: Scheme Syntax Extension Packages + +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 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 +-------- + + ;;; These definitions for PRINT and SIZE are + ;;; already supplied by + (require 'yasos) + + (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: Textual Conversion Packages, Next: Mathematical Packages, Prev: Scheme Syntax Extension Packages, Up: Top + +Textual Conversion Packages +*************************** + +* Menu: + +* Precedence Parsing:: +* Format:: Common-Lisp Format +* Standard Formatted I/O:: Posix printf and scanf +* Programs and Arguments:: +* HTML:: +* HTML Tables:: Databases meet HTML +* HTTP and CGI:: Serve WWW sites +* URI:: Uniform Resource Identifier | +* Printing Scheme:: Nicely +* Time and Date:: +* Vector Graphics:: +* Schmooz:: Documentation markup for Scheme programs + + +File: slib.info, Node: Precedence Parsing, Next: Format, Prev: Textual Conversion Packages, Up: Textual Conversion Packages + +Precedence Parsing +================== + + `(require 'precedence-parse)' or `(require 'parse)' + +This package implements: + + * a Pratt style precedence parser; + + * a "tokenizer" which congeals tokens according to assigned classes + of constituent characters; + + * procedures giving direct control of parser rulesets; + + * procedures for higher level specification of rulesets. + +* Menu: + +* Precedence Parsing Overview:: +* Ruleset Definition and Use:: +* Token definition:: +* Nud and Led Definition:: +* Grammar Rule Definition:: + + +File: slib.info, Node: Precedence Parsing Overview, Next: Ruleset Definition and Use, Prev: Precedence Parsing, Up: Precedence Parsing + +Precedence Parsing Overview +--------------------------- + +This package offers improvements over previous parsers. + + * Common computer language constructs are concisely specified. + + * Grammars can be changed dynamically. Operators can be assigned + different meanings within a lexical context. + + * Rulesets don't need compilation. Grammars can be changed + incrementally. + + * Operator precedence is specified by integers. + + * All possibilities of bad input are handled (1) and return as much + structure as was parsed when the error occured; The symbol `?' is + substituted for missing input. + +Here are the higher-level syntax types and an example of each. +Precedence considerations are omitted for clarity. See *Note Grammar +Rule Definition:: for full details. + + - Grammar: nofix bye exit + bye + calls the function `exit' with no arguments. + + - Grammar: prefix - negate + - 42 + Calls the function `negate' with the argument `42'. + + - Grammar: infix - difference + x - y + Calls the function `difference' with arguments `x' and `y'. + + - Grammar: nary + sum + x + y + z + Calls the function `sum' with arguments `x', `y', and `y'. + + - Grammar: postfix ! factorial + 5 ! + Calls the function `factorial' with the argument `5'. + + - Grammar: prestfix set set! + set foo bar + Calls the function `set!' with the arguments `foo' and `bar'. + + - Grammar: commentfix /* */ + /* almost any text here */ + Ignores the comment delimited by `/*' and `*/'. + + - Grammar: matchfix { list } + {0, 1, 2} + Calls the function `list' with the arguments `0', `1', and `2'. + + - Grammar: inmatchfix ( funcall ) + f(x, y) + Calls the function `funcall' with the arguments `f', `x', and `y'. + + - Grammar: delim ; + set foo bar; + delimits the extent of the restfix operator `set'. + + ---------- Footnotes ---------- + + (1) How do I know this? I parsed 250kbyte of random input (an e-mail +file) with a non-trivial grammar utilizing all constructs. + + +File: slib.info, Node: Ruleset Definition and Use, Next: Token definition, Prev: Precedence Parsing Overview, Up: Precedence Parsing + +Ruleset Definition and Use +-------------------------- + + - Variable: *syn-defs* + A grammar is built by one or more calls to `prec:define-grammar'. + The rules are appended to *SYN-DEFS*. The value of *SYN-DEFS* is + the grammar suitable for passing as an argument to `prec:parse'. + + - Constant: *syn-ignore-whitespace* + Is a nearly empty grammar with whitespace characters set to group + 0, which means they will not be made into tokens. Most rulesets + will want to start with `*syn-ignore-whitespace*' + +In order to start defining a grammar, either + + (set! *syn-defs* '()) + +or + + (set! *syn-defs* *syn-ignore-whitespace*) + + - Function: prec:define-grammar rule1 ... + Appends RULE1 ... to *SYN-DEFS*. `prec:define-grammar' is used to + define both the character classes and rules for tokens. + +Once your grammar is defined, save the value of `*syn-defs*' in a +variable (for use when calling `prec:parse'). + + (define my-ruleset *syn-defs*) + + - Function: prec:parse ruleset delim + - Function: prec:parse ruleset delim port + The RULESET argument must be a list of rules as constructed by + `prec:define-grammar' and extracted from *SYN-DEFS*. + + The token DELIM may be a character, symbol, or string. A + character DELIM argument will match only a character token; i.e. a + character for which no token-group is assigned. A symbols or + string will match only a token string; i.e. a token resulting from + a token group. + + `prec:parse' reads a RULESET grammar expression delimited by DELIM + from the given input PORT. `prec:parse' returns the next object + parsable from the given input PORT, updating PORT to point to the + first character past the end of the external representation of the + object. + + If an end of file is encountered in the input before any + characters are found that can begin an object, then an end of file + object is returned. If a delimiter (such as DELIM) is found + before any characters are found that can begin an object, then + `#f' is returned. + + The PORT argument may be omitted, in which case it defaults to the + value returned by `current-input-port'. It is an error to parse + from a closed port. + + +File: slib.info, Node: Token definition, Next: Nud and Led Definition, Prev: Ruleset Definition and Use, Up: Precedence Parsing + +Token definition +---------------- + + - Function: tok:char-group group chars chars-proc + The argument CHARS may be a single character, a list of + characters, or a string. Each character in CHARS is treated as + though `tok:char-group' was called with that character alone. + + The argument CHARS-PROC must be a procedure of one argument, a + list of characters. After `tokenize' has finished accumulating + the characters for a token, it calls CHARS-PROC with the list of + characters. The value returned is the token which `tokenize' + returns. + + The argument GROUP may be an exact integer or a procedure of one + character argument. The following discussion concerns the + treatment which the tokenizing routine, `tokenize', will accord to + characters on the basis of their groups. + + When GROUP is a non-zero integer, characters whose group number is + equal to or exactly one less than GROUP will continue to + accumulate. Any other character causes the accumulation to stop + (until a new token is to be read). + + The GROUP of zero is special. These characters are ignored when + parsed pending a token, and stop the accumulation of token + characters when the accumulation has already begun. Whitespace + characters are usually put in group 0. + + If GROUP is a procedure, then, when triggerd by the occurence of + an initial (no accumulation) CHARS character, this procedure will + be repeatedly called with each successive character from the input + stream until the GROUP procedure returns a non-false value. + +The following convenient constants are provided for use with +`tok:char-group'. + + - Constant: tok:decimal-digits + Is the string `"0123456789"'. + + - Constant: tok:upper-case + Is the string consisting of all upper-case letters + ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"). + + - Constant: tok:lower-case + Is the string consisting of all lower-case letters + ("abcdefghijklmnopqrstuvwxyz"). + + - Constant: tok:whitespaces + Is the string consisting of all characters between 0 and 255 for + which `char-whitespace?' returns true. + + +File: slib.info, Node: Nud and Led Definition, Next: Grammar Rule Definition, Prev: Token definition, Up: Precedence Parsing + +Nud and Led Definition +---------------------- + + This section describes advanced features. You can skip this section +on first reading. + +The "Null Denotation" (or "nud") of a token is the procedure and +arguments applying for that token when "Left", an unclaimed parsed +expression is not extant. + +The "Left Denotation" (or "led") of a token is the procedure, +arguments, and lbp applying for that token when there is a "Left", an +unclaimed parsed expression. + +In his paper, + + Pratt, V. R. Top Down Operator Precendence. `SIGACT/SIGPLAN + Symposium on Principles of Programming Languages', Boston, 1973, + pages 41-51 + + the "left binding power" (or "lbp") was an independent property of +tokens. I think this was done in order to allow tokens with NUDs but +not LEDs to also be used as delimiters, which was a problem for +statically defined syntaxes. It turns out that _dynamically binding_ +NUDs and LEDs allows them independence. + +For the rule-defining procedures that follow, the variable TK may be a +character, string, or symbol, or a list composed of characters, +strings, and symbols. Each element of TK is treated as though the +procedure were called for each element. + +Character TK arguments will match only character tokens; i.e. +characters for which no token-group is assigned. Symbols and strings +will both match token strings; i.e. tokens resulting from token groups. + + - Function: prec:make-nud tk sop arg1 ... + Returns a rule specifying that SOP be called when TK is parsed. + If SOP is a procedure, it is called with TK and ARG1 ... as its + arguments; the resulting value is incorporated into the expression + being built. Otherwise, `(list SOP ARG1 ...)' is incorporated. + +If no NUD has been defined for a token; then if that token is a string, +it is converted to a symbol and returned; if not a string, the token is +returned. + + - Function: prec:make-led tk sop arg1 ... + Returns a rule specifying that SOP be called when TK is parsed and + LEFT has an unclaimed parsed expression. If SOP is a procedure, + it is called with LEFT, TK, and ARG1 ... as its arguments; the + resulting value is incorporated into the expression being built. + Otherwise, LEFT is incorporated. + +If no LED has been defined for a token, and LEFT is set, the parser +issues a warning. + + +File: slib.info, Node: Grammar Rule Definition, Prev: Nud and Led Definition, Up: Precedence Parsing + +Grammar Rule Definition +----------------------- + +Here are procedures for defining rules for the syntax types introduced +in *Note Precedence Parsing Overview::. + +For the rule-defining procedures that follow, the variable TK may be a +character, string, or symbol, or a list composed of characters, +strings, and symbols. Each element of TK is treated as though the +procedure were called for each element. + +For procedures prec:delim, ..., prec:prestfix, if the SOP argument is +`#f', then the token which triggered this rule is converted to a symbol +and returned. A false SOP argument to the procedures prec:commentfix, +prec:matchfix, or prec:inmatchfix has a different meaning. + +Character TK arguments will match only character tokens; i.e. +characters for which no token-group is assigned. Symbols and strings +will both match token strings; i.e. tokens resulting from token groups. + + - Function: prec:delim tk + Returns a rule specifying that TK should not be returned from + parsing; i.e. TK's function is purely syntactic. The end-of-file + is always treated as a delimiter. + + - Function: prec:nofix tk sop + Returns a rule specifying the following actions take place when TK + is parsed: + * If SOP is a procedure, it is called with no arguments; the + resulting value is incorporated into the expression being + built. Otherwise, the list of SOP is incorporated. + + - Function: prec:prefix tk sop bp rule1 ... + Returns a rule specifying the following actions take place when TK + is parsed: + * The rules RULE1 ... augment and, in case of conflict, override + rules currently in effect. + + * `prec:parse1' is called with binding-power BP. + + * If SOP is a procedure, it is called with the expression + returned from `prec:parse1'; the resulting value is + incorporated into the expression being built. Otherwise, the + list of SOP and the expression returned from `prec:parse1' is + incorporated. + + * The ruleset in effect before TK was parsed is restored; RULE1 + ... are forgotten. + + - Function: prec:infix tk sop lbp bp rule1 ... + Returns a rule declaring the left-binding-precedence of the token + TK is LBP and specifying the following actions take place when TK + is parsed: + * The rules RULE1 ... augment and, in case of conflict, override + rules currently in effect. + + * One expression is parsed with binding-power LBP. If instead a + delimiter is encountered, a warning is issued. + + * If SOP is a procedure, it is applied to the list of LEFT and + the parsed expression; the resulting value is incorporated + into the expression being built. Otherwise, the list of SOP, + the LEFT expression, and the parsed expression is + incorporated. + + * The ruleset in effect before TK was parsed is restored; RULE1 + ... are forgotten. + + - Function: prec:nary tk sop bp + Returns a rule declaring the left-binding-precedence of the token + TK is BP and specifying the following actions take place when TK + is parsed: + * Expressions are parsed with binding-power BP as far as they + are interleaved with the token TK. + + * If SOP is a procedure, it is applied to the list of LEFT and + the parsed expressions; the resulting value is incorporated + into the expression being built. Otherwise, the list of SOP, + the LEFT expression, and the parsed expressions is + incorporated. + + - Function: prec:postfix tk sop lbp + Returns a rule declaring the left-binding-precedence of the token + TK is LBP and specifying the following actions take place when TK + is parsed: + * If SOP is a procedure, it is called with the LEFT expression; + the resulting value is incorporated into the expression being + built. Otherwise, the list of SOP and the LEFT expression is + incorporated. + + - Function: prec:prestfix tk sop bp rule1 ... + Returns a rule specifying the following actions take place when TK + is parsed: + * The rules RULE1 ... augment and, in case of conflict, override + rules currently in effect. + + * Expressions are parsed with binding-power BP until a + delimiter is reached. + + * If SOP is a procedure, it is applied to the list of parsed + expressions; the resulting value is incorporated into the + expression being built. Otherwise, the list of SOP and the + parsed expressions is incorporated. + + * The ruleset in effect before TK was parsed is restored; RULE1 + ... are forgotten. + + - Function: prec:commentfix tk stp match rule1 ... + Returns rules specifying the following actions take place when TK + is parsed: + * The rules RULE1 ... augment and, in case of conflict, override + rules currently in effect. + + * Characters are read until and end-of-file or a sequence of + characters is read which matches the _string_ MATCH. + + * If STP is a procedure, it is called with the string of all + that was read between the TK and MATCH (exclusive). + + * The ruleset in effect before TK was parsed is restored; RULE1 + ... are forgotten. + + Parsing of commentfix syntax differs from the others in several + ways. It reads directly from input without tokenizing; It calls + STP but does not return its value; nay any value. I added the STP + argument so that comment text could be echoed. + + - Function: prec:matchfix tk sop sep match rule1 ... + Returns a rule specifying the following actions take place when TK + is parsed: + * The rules RULE1 ... augment and, in case of conflict, override + rules currently in effect. + + * A rule declaring the token MATCH a delimiter takes effect. + + * Expressions are parsed with binding-power `0' until the token + MATCH is reached. If the token SEP does not appear between + each pair of expressions parsed, a warning is issued. + + * If SOP is a procedure, it is applied to the list of parsed + expressions; the resulting value is incorporated into the + expression being built. Otherwise, the list of SOP and the + parsed expressions is incorporated. + + * The ruleset in effect before TK was parsed is restored; RULE1 + ... are forgotten. + + - Function: prec:inmatchfix tk sop sep match lbp rule1 ... + Returns a rule declaring the left-binding-precedence of the token + TK is LBP and specifying the following actions take place when TK + is parsed: + * The rules RULE1 ... augment and, in case of conflict, override + rules currently in effect. + + * A rule declaring the token MATCH a delimiter takes effect. + + * Expressions are parsed with binding-power `0' until the token + MATCH is reached. If the token SEP does not appear between + each pair of expressions parsed, a warning is issued. + + * If SOP is a procedure, it is applied to the list of LEFT and + the parsed expressions; the resulting value is incorporated + into the expression being built. Otherwise, the list of SOP, + the LEFT expression, and the parsed expressions is + incorporated. + + * The ruleset in effect before TK was parsed is restored; RULE1 + ... are forgotten. + + +File: slib.info, Node: Format, Next: Standard Formatted I/O, Prev: Precedence Parsing, Up: Textual Conversion Packages + +Format (version 3.0) +==================== + + `(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 "old fashioned" 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: Standard Formatted I/O, Next: Programs and Arguments, Prev: Format, Up: Textual Conversion Packages + +Standard Formatted I/O +====================== + +* Menu: + +* Standard Formatted Output:: 'printf +* Standard Formatted Input:: 'scanf + +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 ... + - Procedure: sprintf #f format arg1 ... + - Procedure: sprintf k 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. + + Two extensions of `sprintf' return new strings. If the first + argument is `#f', then the returned string's length is as many + characters as specified by the FORMAT and data; if the first + argument is a non-negative integer K, then the length of the + returned string is also bounded by K. + + 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 +................... + + `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 fixed or exponential + notation, whichever is more appropriate for its magnitude. + Unless an `#' flag has been supplied, trailing zeros after a + decimal point will be stripped off. `%g' prints `e' between + mantissa and exponont. `%G' prints `E' between mantissa and + exponent. + + `k', `K' + Print a number like `%g', except that an SI prefix is output + after the number, which is scaled accordingly. `%K' outputs + a space between number and prefix, `%k' does not. + +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: Programs and Arguments, Next: HTML, Prev: Standard Formatted I/O, Up: Textual Conversion Packages + +Program and Arguments +===================== + +* Menu: + +* Getopt:: Command Line option parsing +* Command Line:: A command line reader for Scheme shells +* Parameter lists:: 'parameters +* Getopt Parameter lists:: 'getopt-parameters +* Filenames:: 'glob or 'filename +* Batch:: 'batch + + +File: slib.info, Node: Getopt, Next: Command Line, Prev: Programs and Arguments, Up: Programs and Arguments + +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: Parameter lists, Prev: Getopt, Up: Programs and Arguments + +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 <newline>s in comments are also ignored. + + - Function: read-options-file filename + `read-options-file' converts an "options file" into a list of + strings suitable for parsing by `getopt'. The syntax of options + files is the same as the syntax for command lines, except that + <newline>s do not terminate reading (only <;> or end of file). + + If an end of file is encountered before any characters are found + that can begin an object or comment, then an end of file object is + returned. + + +File: slib.info, Node: Parameter lists, Next: Getopt Parameter lists, Prev: Command Line, Up: Programs and Arguments + +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. + + - Function: remove-parameter parameter-name parameter-list + Removes the parameter PARAMETER-NAME from PARAMETER-LIST. + `remove-parameter' does not alter the argument PARAMETER-LIST. + + If there are more than one PARAMETER-NAME parameters, an error is + signaled. + + - 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 defaulters parameter-list + DEFAULTERS 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. `fill-empty-parameters' returns a new + parameter-list with each empty parameter replaced with the list + returned by calling the corresponding DEFAULTER with + PARAMETER-LIST as its argument. + + - 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' a warning 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 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). | + + 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. + + +File: slib.info, Node: Getopt Parameter lists, Next: Filenames, Prev: Parameter lists, Up: Programs and Arguments + +Getopt Parameter lists +---------------------- + + `(require 'getopt-parameters)' + + - Function: getopt->parameter-list argc argv optnames arities types + aliases desc ... | + Returns ARGV converted to a parameter-list. OPTNAMES are the + parameter-names. ARITIES and TYPES are lists of symbols | + corresponding to OPTNAMES. | + | + ALIASES is a list of lists of strings or integers paired with | + elements of OPTNAMES. Each one-character string will be treated | + as a single `-' option by `getopt'. Longer strings will be | + treated as long-named options (*note getopt-: Getopt.). | + | + If the ALIASES association list has only strings as its `car's, | + then all the option-arguments after an option (and before the next | + option) are adjoined to that option. | + | + If the ALIASES association list has integers, then each (string) | + option will take at most one option-argument. Unoptioned | + arguments are collected in a list. A `-1' alias will take the | + last argument in this list; `+1' will take the first argument in | + the list. The aliases -2 then +2; -3 then +3; ... are tried so | + long as a positive or negative consecutive alias is found and | + arguments remain in the list. Finally a `0' alias, if found, | + absorbs any remaining arguments. | + | + In all cases, if unclaimed arguments remain after processing, a | + warning is signaled and #f is returned. | + + - Function: getopt->arglist argc argv optnames positions arities types + defaulters checks aliases desc ... | + Like `getopt->parameter-list', but converts ARGV to an + argument-list as specified by OPTNAMES, POSITIONS, ARITIES, TYPES, + DEFAULTERS, CHECKS, and ALIASES. If the options supplied violate | + the ARITIES or CHECKS constraints, then a warning is signaled and | + #f is returned. | + +These `getopt' functions can be used with SLIB relational databases. +For an example, *Note make-command-server: Database Utilities. + +If errors are encountered while processing options, directions for using +the options (and argument strings DESC ...) are printed to | +`current-error-port'. | + + (begin + (set! *optind* 1) + (getopt->parameter-list + 2 + '("cmd" "-?") + '(flag number symbols symbols string flag2 flag3 num2 num3) + '(boolean optional nary1 nary single boolean boolean nary nary) + '(boolean integer symbol symbol string boolean boolean integer integer) + '(("flag" flag) + ("f" flag) + ("Flag" flag2) + ("B" flag3) + ("optional" number) + ("o" number) + ("nary1" symbols) + ("N" symbols) + ("nary" symbols) + ("n" symbols) + ("single" string) + ("s" string) + ("a" num2) + ("Abs" num3)))) + -| + Usage: cmd [OPTION ARGUMENT ...] ... + + -f, --flag + -o, --optional=<number> + -n, --nary=<symbols> ... + -N, --nary1=<symbols> ... + -s, --single=<string> + --Flag + -B + -a <num2> ... + --Abs=<num3> ... + + ERROR: getopt->parameter-list "unrecognized option" "-?" + + +File: slib.info, Node: Filenames, Next: Batch, Prev: Getopt Parameter lists, Up: Programs and Arguments + +Filenames +--------- + + `(require 'filename)' or `(require 'glob)' + + - Function: filename:match?? pattern + - Function: filename:match-ci?? pattern + Returns a predicate which returns a non-false value if its string + argument matches (the string) PATTERN, false otherwise. Filename + matching is like "glob" expansion described the bash manpage, + except that names beginning with `.' are matched and `/' + characters are not treated specially. + + These functions interpret the following characters specially in + PATTERN strings: + `*' + Matches any string, including the null string. + + `?' + Matches any single character. + + `[...]' + Matches any one of the enclosed characters. A pair of + characters separated by a minus sign (-) denotes a range; any + character lexically between those two characters, inclusive, + is matched. If the first character following the `[' is a + `!' or a `^' then any character not enclosed is matched. A + `-' or `]' may be matched by including it as the first or + last character in the set. + + + - Function: filename:substitute?? pattern template + - Function: filename:substitute-ci?? pattern template + Returns a function transforming a single string argument according + to glob patterns PATTERN and TEMPLATE. PATTERN and TEMPLATE must + have the same number of wildcard specifications, which need not be + identical. PATTERN and TEMPLATE may have a different number of + literal sections. If an argument to the function matches PATTERN + in the sense of `filename:match??' then it returns a copy of + TEMPLATE in which each wildcard specification is replaced by the + part of the argument matched by the corresponding wildcard + specification in PATTERN. A `*' wildcard matches the longest + leftmost string possible. If the argument does not match PATTERN + then false is returned. + + TEMPLATE may be a function accepting the same number of string + arguments as there are wildcard specifications in PATTERN. In the + case of a match the result of applying TEMPLATE to a list of the + substrings matched by wildcard specifications will be returned, + otherwise TEMPLATE will not be called and `#f' will be returned. + + ((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm") + "scm_10.html") + => "scm5c4_10.htm" + ((filename:substitute?? "??" "beg?mid?end") "AZ") + => "begAmidZend" + ((filename:substitute?? "*na*" "?NA?") "banana") + => "banaNA" + ((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1))) "ABZ") + => "ZA" + + - Function: replace-suffix str old new + STR can be a string or a list of strings. Returns a new string + (or strings) 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. + + (replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c") + => "/usr/local/lib/slib/batch.c" + + +File: slib.info, Node: Batch, Prev: Filenames, Up: Programs and Arguments + +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 + + * amigados + + * 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. + +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:command parms string1 string2 ... + Calls `batch:try-command' (below) with arguments, but signals an + error if `batch:try-command' 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-command parms string1 string2 ... + Writes a command to the `batch-port' in PARMS which executes the + program named STRING1 with arguments STRING2 .... + + - Function: batch:try-chopped-command parms arg1 arg2 ... list + breaks the last argument LIST into chunks small enough so that the + command: + + ARG1 ARG2 ... CHUNK + + fits withing the platform's maximum command-line length. + + `batch:try-chopped-command' calls `batch:try-command' with the + command and returns non-false only if the commands all fit and + `batch:try-command' of each command line returned non-false. + + - 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-command' 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: truncate-up-to path char + - Function: truncate-up-to path string + - Function: truncate-up-to path charlist + PATH can be a string or a list of strings. Returns PATH sans any + prefixes ending with a character of the second argument. This can + be used to derive a filename moved locally from elsewhere. + + (truncate-up-to "/usr/local/lib/slib/batch.scm" "/") + => "batch.scm" + + - 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) + (require 'glob) + + (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:command my-parameters "cc" "-c" "hello.c") + (batch:command my-parameters "cc" "-o" "hello" + (replace-suffix "hello.c" ".c" ".o")) + (batch:command 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" script created by SLIB/batch Sun Oct 31 18:24:10 1999 + # ================ 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: HTML, Next: HTML Tables, Prev: Programs and Arguments, Up: Textual Conversion Packages + +HTML +==== + + `(require 'html-form)' + + - Function: html:atval txt + Returns a string with character substitutions appropriate to send + TXT as an "attribute-value". + + - Function: html:plain txt + Returns a string with character substitutions appropriate to send + TXT as an "plain-text". + + - Function: html:meta name content | + Returns a tag of meta-information suitable for passing as the | + third argument to `html:head'. The tag produced is `<META | + NAME="NAME" CONTENT="CONTENT">'. The string or symbol NAME can be | + `author', `copyright', `keywords', `description', `date', | + `robots', .... | + | + - Function: html:http-equiv name content | + Returns a tag of HTTP information suitable for passing as the | + third argument to `html:head'. The tag produced is `<META | + HTTP-EQUIV="NAME" CONTENT="CONTENT">'. The string or symbol NAME | + can be `Expires', `PICS-Label', `Content-Type', `Refresh', .... | + | + - Function: html:meta-refresh delay uri | + - Function: html:meta-refresh delay | + Returns a tag suitable for passing as the third argument to | + `html:head'. If URI argument is supplied, then DELAY seconds after | + displaying the page with this tag, Netscape or IE browsers will | + fetch and display URI. Otherwise, DELAY seconds after displaying | + the page with this tag, Netscape or IE browsers will fetch and | + redisplay this page. | + | + - Function: html:head title backlink tags ... + - Function: html:head title backlink + - Function: html:head title + Returns header string for an HTML page named TITLE. If BACKLINK | + is a string, it is used verbatim between the `H1' tags; otherwise | + TITLE is used. If string arguments TAGS ... are supplied, then | + they are included verbatim within the <HEAD> section. | + + - Function: html:body body ... + Returns HTML string to end a page. + + - Function: html:pre line1 line ... + Returns the strings LINE1, LINES as "PRE"formmated plain text + (rendered in fixed-width font). Newlines are inserted between + LINE1, LINES. HTML tags (`<tag>') within LINES will be visible + verbatim. + + - Function: html:comment line1 line ... + Returns the strings LINE1 as HTML comments. + +HTML Forms +========== + + - Function: html:form method action body ... | + The symbol METHOD is either `get', `head', `post', `put', or + `delete'. The strings BODY form the body of the form. | + `html:form' returns the HTML "form". + + - Function: html:hidden name value | + Returns HTML string which will cause NAME=VALUE in form. | + | + - Function: html:checkbox pname default | + Returns HTML string for check box. | + | + - Function: html:text pname default size ... | + Returns HTML string for one-line text box. | + | + - Function: html:text-area pname default-list | + Returns HTML string for multi-line text box. | + | + - Function: html:select pname arity default-list foreign-values | + Returns HTML string for pull-down menu selector. | + | + - Function: html:buttons pname arity default-list foreign-values | + Returns HTML string for any-of selector. | + | + - Function: form:submit submit-label command | + - Function: form:submit submit-label | + The string or symbol SUBMIT-LABEL appears on the button which | + submits the form. If the optional second argument COMMAND is | + given, then `*command*=COMMAND' and `*button*=SUBMIT-LABEL' are | + set in the query. Otherwise, `*command*=SUBMIT-LABEL' is set in | + the query. | + | + - Function: form:image submit-label image-src | + The IMAGE-SRC appears on the button which submits the form. | + | + - Function: form:reset | + Returns a string which generates a "reset" button. | + | + - Function: form:element pname arity default-list foreign-values | + Returns a string which generates an INPUT element for the field | + named PNAME. The element appears in the created form with its | + representation determined by its ARITY and domain. For domains | + which are foreign-keys: | + | + `single' | + select menu | + | + `optional' | + select menu | + | + `nary' | + check boxes | + | + `nary1' | + check boxes | + | + If the foreign-key table has a field named `visible-name', then | + the contents of that field are the names visible to the user for | + those choices. Otherwise, the foreign-key itself is visible. | + | + For other types of domains: | + | + `single' | + text area | + | + `optional' | + text area | + | + `boolean' | + check box | + | + `nary' | + text area | + | + `nary1' | + text area | + | + - Function: form:delimited pname doc aliat arity default-list | + foreign-values | + Returns a HTML string for a form element embedded in a line of a | + delimited list. Apply map `form:delimited' to the list returned by | + `command->p-specs'. | + | + - Function: command->p-specs rdb command-table command | + The symbol COMMAND-TABLE names a command table in the RDB + relational database. The symbol COMMAND names a key in | + COMMAND-TABLE. | + + `command->p-specs' returns a list of lists of PNAME, DOC, ALIAT, | + ARITY, DEFAULT-LIST, and FOREIGN-VALUES. The returned list has | + one element for each parameter of command COMMAND. | + + This example demonstrates how to create a HTML-form for the `build' + command. + + (require (in-vicinity (implementation-vicinity) "build.scm")) + (call-with-output-file "buildscm.html" + (lambda (port) + (display + (string-append + (html:head 'commands) + (html:body + (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n" | + (html:plain 'build) | + (html:plain ((comtab 'get 'documentation) 'build))) | + (html:form | + 'post | + (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") | + (apply html:delimited-list | + (apply map form:delimited | + (command->p-specs build '*commands* 'build))) | + (form:submit 'build) | + (form:reset)))) | + port))) + + +File: slib.info, Node: HTML Tables, Next: HTTP and CGI, Prev: HTML, Up: Textual Conversion Packages + +HTML Tables +=========== + + `(require 'db->html)' + + - Function: html:table options row ... | + | + - Function: html:caption caption align | + - Function: html:caption caption | + ALIGN can be `top' or `bottom'. | + + - Function: html:heading columns + Outputs a heading row for the currently-started table. + + - Function: html:href-heading columns uris | + Outputs a heading row with column-names COLUMNS linked to URIs | + URIS. | + + - Function: html:linked-row-converter k foreigns | + The positive integer K is the primary-key-limit (number of + primary-keys) of the table. FOREIGNS is a list of the filenames of + foreign-key field pages and #f for non foreign-key fields. + + `html:linked-row-converter' returns a procedure taking a row for | + its single argument. This returned procedure returns the html | + string for that table row. | + + - Function: table-name->filename table-name + Returns the symbol TABLE-NAME converted to a filename. + + - Function: table->linked-html caption db table-name match-key1 ... | + Returns HTML string for DB table TABLE-NAME. Every foreign-key | + value is linked to the page (of the table) defining that key. | + + The optional MATCH-KEY1 ... arguments restrict actions to a subset + of the table. *Note match-key: Table Operations. + + - Function: table->linked-page db table-name index-filename arg ... | + Returns a complete HTML page. The string INDEX-FILENAME names the + page which refers to this one. + + The optional ARGS ... arguments restrict actions to a subset of + the table. *Note match-key: Table Operations. + + - Function: catalog->html db caption arg ... + Returns HTML string for the catalog table of DB. + +HTML editing tables | +------------------- | + | +A client can modify one row of an editable table at a time. For any | +change submitted, these routines check if that row has been modified | +during the time the user has been editing the form. If so, an error | +page results. | + | +The behavior of edited rows is: | + | + * If no fields are changed, then no change is made to the table. | + | + * If the primary keys equal null-keys (parameter defaults), and no | + other user has modified that row, then that row is deleted. | + | + * If only primary keys are changed, there are non-key fields, and no | + row with the new keys is in the table, then the old row is deleted | + and one with the new keys is inserted. | + | + * If only non-key fields are changed, and that row has not been | + modified by another user, then the row is changed to reflect the | + fields. | + | + * If both keys and non-key fields are changed, and no row with the | + new keys is in the table, then a row is created with the new keys | + and fields. | + | + * If fields are changed, all fields are primary keys, and no row with | + the new keys is in the table, then a row is created with the new | + keys. | + | +After any change to the table, a `sync-database' of the database is | +performed. | + | + - Function: command:modify-table table-name null-keys update delete | + retrieve | + - Function: command:modify-table table-name null-keys update delete | + - Function: command:modify-table table-name null-keys update | + - Function: command:modify-table table-name null-keys | + Returns procedure (of DB) which returns procedure to modify row of | + TABLE-NAME. NULL-KEYS is the list of "null" keys which indicate | + that the row is to be deleted. Optional arguments UPDATE, DELETE, | + and RETRIEVE default to the `row:update', `row:delete', and | + `row:retrieve' of TABLE-NAME in DB. | + | + - Function: command:make-editable-table rdb table-name arg ... | + Given TABLE-NAME in RDB, creates parameter and `*command*' tables | + for editing one row of TABLE-NAME at a time. | + `command:make-editable-table' returns a procedure taking a row | + argument which returns the HTML string for editing that row. | + | + Optional ARGS are expressions (lists) added to the call to | + `command:modify-table'. | + | + The domain name of a column determines the expected arity of the | + data stored in that column. Domain names ending in: | + | + `*' | + have arity `nary'; | + | + `+' | + have arity `nary1'. | + | + - Function: html:editable-row-converter k names edit-point | + edit-converter | + The positive integer K is the primary-key-limit (number of | + primary-keys) of the table. NAMES is a list of the field-names. | + EDIT-POINT is the list of primary-keys denoting the row to edit | + (or #f). EDIT-CONVERTER is the procedure called with K, NAMES, | + and the row to edit. | + | + `html:editable-row-converter' returns a procedure taking a row for | + its single argument. This returned procedure returns the html | + string for that table row. | + | + Each HTML table constructed using `html:editable-row-converter' | + has first K fields (typically the primary key fields) of each row | + linked to a text encoding of these fields (the result of calling | + `row->anchor'). The page so referenced typically allows the user | + to edit fields of that row. | + +HTML databases +-------------- + + - Function: db->html-files db dir index-filename caption | + DB must be a relational database. DIR must be #f or a non-empty + string naming an existing sub-directory of the current directory. + + `db->html-files' creates an html page for each table in the | + database DB in the sub-directory named DIR, or the current | + directory if DIR is #f. The top level page with the catalog of | + tables (captioned CAPTION) is written to a file named | + INDEX-FILENAME. | + + - Function: db->html-directory db dir index-filename | + - Function: db->html-directory db dir | + DB must be a relational database. DIR must be a non-empty string + naming an existing sub-directory of the current directory or one + to be created. The optional string INDEX-FILENAME names the + filename of the top page, which defaults to `index.html'. + + `db->html-directory' creates sub-directory DIR if neccessary, and | + calls `(db->html-files DB DIR INDEX-FILENAME DIR)'. The `file:' | + URI of INDEX-FILENAME is returned. | + + - Function: db->netscape db dir index-filename + - Function: db->netscape db dir + `db->netscape' is just like `db->html-directory', but calls | + `browse-url-netscape' with the uri for the top page after the | + pages are created. + + +File: slib.info, Node: HTTP and CGI, Next: URI, Prev: HTML Tables, Up: Textual Conversion Packages + | +HTTP and CGI +============ + + `(require 'http)' or `(require 'cgi)' + | + - Function: http:header alist + Returns a string containing lines for each element of ALIST; the + `car' of which is followed by `: ', then the `cdr'. + + - Function: http:content alist body ... + Returns the concatenation of strings BODY with the `(http:header + ALIST)' and the `Content-Length' prepended. + + - Variable: *http:byline* + String appearing at the bottom of error pages. + + - Function: http:error-page status-code reason-phrase html-string ... + STATUS-CODE and REASON-PHRASE should be an integer and string as + specified in `RFC 2068'. The returned page (string) will show the + STATUS-CODE and REASON-PHRASE and any additional HTML-STRINGS ...; + with *HTTP:BYLINE* or SLIB's default at the bottom. + + - Function: http:forwarding-page title delay uri html-string ... | + The string or symbol TITLE is the page title. DELAY is a | + non-negative integer. The HTML-STRINGS ... are typically used to | + explain to the user why this page is being forwarded. | + | + `http:forwarding-page' returns an HTML string for a page which | + automatically forwards to URI after DELAY seconds. The returned | + page (string) contains any HTML-STRINGS ... followed by a manual | + link to URI, in case the browser does not forward automatically. | + | + - Function: http:serve-query serve-proc input-port output-port + reads the "URI" and "query-string" from INPUT-PORT. If the query + is a valid `"POST"' or `"GET"' query, then `http:serve-query' calls + SERVE-PROC with three arguments, the REQUEST-LINE, QUERY-STRING, + and HEADER-ALIST. Otherwise, `http:serve-query' calls SERVE-PROC + with the REQUEST-LINE, #f, and HEADER-ALIST. + + If SERVE-PROC returns a string, it is sent to OUTPUT-PORT. If + SERVE-PROC returns a list, then an error page with number 525 and + strings from the list. If SERVE-PROC returns #f, then a `Bad + Request' (400) page is sent to OUTPUT-PORT. + + Otherwise, `http:serve-query' replies (to OUTPUT-PORT) with + appropriate HTML describing the problem. + + This example services HTTP queries from PORT-NUMBER: + + (define socket (make-stream-socket AF_INET 0)) + (and (socket:bind socket port-number) ; AF_INET INADDR_ANY + (socket:listen socket 10) ; Queue up to 10 requests. + (dynamic-wind + (lambda () #f) + (lambda () + (do ((port (socket:accept socket) (socket:accept socket))) + (#f) + (let ((iport (duplicate-port port "r")) + (oport (duplicate-port port "w"))) + (http:serve-query build:serve iport oport) + (close-port iport) + (close-port oport)) + (close-port port))) + (lambda () (close-port socket)))) + + - Function: cgi:serve-query serve-proc + reads the "URI" and "query-string" from `(current-input-port)'. + If the query is a valid `"POST"' or `"GET"' query, then + `cgi:serve-query' calls SERVE-PROC with three arguments, the + REQUEST-LINE, QUERY-STRING, and HEADER-ALIST. Otherwise, + `cgi:serve-query' calls SERVE-PROC with the REQUEST-LINE, #f, and + HEADER-ALIST. + + If SERVE-PROC returns a string, it is sent to + `(current-input-port)'. If SERVE-PROC returns a list, then an + error page with number 525 and strings from the list. If + SERVE-PROC returns #f, then a `Bad Request' (400) page is sent to + `(current-input-port)'. + + Otherwise, `cgi:serve-query' replies (to `(current-input-port)') + with appropriate HTML describing the problem. + + - Function: make-query-alist-command-server rdb command-table | + - Function: make-query-alist-command-server rdb command-table #t | + Returns a procedure of one argument. When that procedure is called + with a QUERY-ALIST (as returned by `uri:decode-query', the value | + of the `*command*' association will be the command invoked in | + COMMAND-TABLE. If `*command*' is not in the QUERY-ALIST then the | + value of `*suggest*' is tried. If neither name is in the | + QUERY-ALIST, then the literal value `*default*' is tried in | + COMMAND-TABLE. | + | + If optional third argument is non-false, then the command is called | + with just the parameter-list; otherwise, command is called with the | + arguments described in its table. | + | + +File: slib.info, Node: URI, Next: Printing Scheme, Prev: HTTP and CGI, Up: Textual Conversion Packages + | +URI | +=== | + | + `(require 'uri)' | + | +Implements "Uniform Resource Identifiers" (URI) as described in RFC | +2396. | + | + - Function: make-uri | + - Function: make-uri fragment | + - Function: make-uri query fragment | + - Function: make-uri path query fragment | + - Function: make-uri authority path query fragment | + - Function: make-uri scheme authority path query fragment | + Returns a Uniform Resource Identifier string from component | + arguments. | + | + - Function: html:anchor name | + Returns a string which defines this location in the (HTML) file as | + NAME. The hypertext `<A HREF="#NAME">' will link to this point. | + | + (html:anchor "(section 7)") | + => | + "<A NAME=\"(section%207)\"></A>" | + | + - Function: html:link uri highlighted | + Returns a string which links the HIGHLIGHTED text to URI. | + | + (html:link (make-uri "(section 7)") "section 7") | + => | + "<A HREF=\"#(section%207)\">section 7</A>" | + | + - Function: html:base uri | + Returns a string specifying the "base" URI of a document, for | + inclusion in the HEAD of the document (*note head: HTML.). | + | + - Function: html:isindex prompt | + Returns a string specifying the search PROMPT of a document, for | + inclusion in the HEAD of the document (*note head: HTML.). | + | + - Function: uri->tree uri-reference base-tree ... | + Returns a list of 5 elements corresponding to the parts (SCHEME | + AUTHORITY PATH QUERY FRAGMENT) of string URI-REFERENCE. Elements | + corresponding to absent parts are #f. | + | + The PATH is a list of strings. If the first string is empty, then | + the path is absolute; otherwise relative. | + | + If the AUTHORITY component is a "Server-based Naming Authority", | + then it is a list of the USERINFO, HOST, and PORT strings (or #f). | + For other types of AUTHORITY components the AUTHORITY will be a | + string. | + | + (uri->tree "http://www.ics.uci.edu/pub/ietf/uri/#Related") | + => | + (http "www.ics.uci.edu" ("" "pub" "ietf" "uri" "") #f "Related") | + | +`uric:' prefixes indicate procedures dealing with URI-components. | + | + - Function: uric:encode uri-component allows | + Returns a copy of the string URI-COMPONENT in which all "unsafe" | + octets (as defined in RFC 2396) have been `%' "escaped". | + `uric:decode' decodes strings encoded by `uric:encode'. | + | + - Function: uric:decode uri-component | + Returns a copy of the string URI-COMPONENT in which each `%' | + escaped characters in URI-COMPONENT is replaced with the character | + it encodes. This routine is useful for showing URI contents on | + error pages. | + + +File: slib.info, Node: Printing Scheme, Next: Time and Date, Prev: URI, Up: Textual Conversion Packages + | +Printing Scheme +=============== + +* Menu: + +* Generic-Write:: 'generic-write +* Object-To-String:: 'object->string +* Pretty-Print:: 'pretty-print, 'pprint-file + + +File: slib.info, Node: Generic-Write, Next: Object-To-String, Prev: Printing Scheme, Up: Printing Scheme + +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: Object-To-String, Next: Pretty-Print, Prev: Generic-Write, Up: Printing Scheme + +Object-To-String +---------------- + + `(require 'object->string)' + + - Function: object->string obj + Returns the textual representation of OBJ as a string. + + - Function: object->limited-string obj limit + Returns the textual representation of OBJ as a string of length at + most LIMIT. + + +File: slib.info, Node: Pretty-Print, Prev: Object-To-String, Up: Printing Scheme + +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)) + + - Procedure: pretty-print->string obj | + - Procedure: pretty-print->string obj width | + Returns the string of OBJ `pretty-print'ed in WIDTH columns. If | + WIDTH is not specified, `(output-port-width)' is used. | + | + Example: | + (pretty-print->string '((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)) | + " | + (pretty-print->string '((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)) | + 16) | + => | + "((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") + + +File: slib.info, Node: Time and Date, Next: Vector Graphics, Prev: Printing Scheme, Up: Textual Conversion Packages + +Time and Date +============= + +* Menu: + +* Time Zone:: +* Posix Time:: 'posix-time +* Common-Lisp Time:: 'common-lisp-time + +If `(provided? 'current-time)': + +The procedures `current-time', `difftime', and `offset-time' deal with +a "calendar time" datatype which may or may not be disjoint from other +Scheme datatypes. + + - 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 Common-Lisp + Time::. + + - Function: difftime caltime1 caltime0 + Returns the difference (number of seconds) between twe calendar + times: CALTIME1 - CALTIME0. CALTIME0 may also be a number. + + - Function: offset-time caltime offset + Returns the calendar time of CALTIME offset by OFFSET number of + seconds `(+ caltime offset)'. + + +File: slib.info, Node: Time Zone, Next: Posix Time, Prev: Time and Date, Up: Time and Date + +Time Zone +--------- + + (require 'time-zone) + + - Data Format: TZ-string + POSIX standards specify several formats for encoding time-zone + rules. + + :<pathname> + If the first character of <pathname> is `/', then <pathname> + specifies the absolute pathname of a tzfile(5) format + time-zone file. Otherwise, <pathname> is interpreted as a + pathname within TZFILE:VICINITY (/usr/lib/zoneinfo/) naming a + tzfile(5) format time-zone file. + + <std><offset> + The string <std> consists of 3 or more alphabetic characters. + <offset> specifies the time difference from GMT. The <offset> + is positive if the local time zone is west of the Prime + Meridian and negative if it is east. <offset> can be the + number of hours or hours and minutes (and optionally seconds) + separated by `:'. For example, `-4:30'. + + <std><offset><dst> + <dst> is the at least 3 alphabetic characters naming the local + daylight-savings-time. + + <std><offset><dst><doffset> + <doffset> specifies the offset from the Prime Meridian when + daylight-savings-time is in effect. + + The non-tzfile formats can optionally be followed by transition + times specifying the day and time when a zone changes from + standard to daylight-savings and back again. + + ,<date>/<time>,<date>/<time> + The <time>s are specified like the <offset>s above, except + that leading `+' and `-' are not allowed. + + Each <date> has one of the formats: + + J<day> + specifies the Julian day with <day> between 1 and 365. + February 29 is never counted and cannot be referenced. + + <day> + This specifies the Julian day with n between 0 and 365. + February 29 is counted in leap years and can be + specified. + + M<month>.<week>.<day> + This specifies day <day> (0 <= <day> <= 6) of week + <week> (1 <= <week> <= 5) of month <month> (1 <= <month> + <= 12). Week 1 is the first week in which day d occurs + and week 5 is the last week in which day <day> occurs. + Day 0 is a Sunday. + + + - Data Type: time-zone + is a datatype encoding how many hours from Greenwich Mean Time the + local time is, and the "Daylight Savings Time" rules for changing + it. + + - Function: time-zone TZ-string + Creates and returns a time-zone object specified by the string + TZ-STRING. If `time-zone' cannot interpret TZ-STRING, `#f' is + returned. + + - Function: tz:params caltime tz + TZ is a time-zone object. `tz:params' returns a list of three + items: + 0. An integer. 0 if standard time is in effect for timezone TZ + at CALTIME; 1 if daylight savings time is in effect for + timezone TZ at CALTIME. + + 1. The number of seconds west of the Prime Meridian timezone TZ + is at CALTIME. + + 2. The name for timezone TZ at CALTIME. + + `tz:params' is unaffected by the default timezone; inquiries can be + made of any timezone at any calendar time. + + +The rest of these procedures and variables are provided for POSIX +compatability. Because of shared state they are not thread-safe. + + - Function: tzset + Returns the default time-zone. + + - Function: tzset tz + Sets (and returns) the default time-zone to TZ. + + - Function: tzset TZ-string + Sets (and returns) the default time-zone to that specified by + TZ-STRING. + + `tzset' also sets the variables *TIMEZONE*, DAYLIGHT?, and TZNAME. + This function is automatically called by the time conversion + procedures which depend on the time zone (*note Time and Date::). + + - Variable: *timezone* + Contains the difference, in seconds, between Greenwich Mean Time + and local standard time (for example, in the U.S. Eastern time + zone (EST), timezone is 5*60*60). `*timezone*' is initialized by + `tzset'. + + - Variable: daylight? + is `#t' if the default timezone has rules for "Daylight Savings + Time". _Note:_ DAYLIGHT? does not tell you when Daylight Savings + Time is in effect, just that the default zone sometimes has + Daylight Savings Time. + + - Variable: tzname + is a vector of strings. Index 0 has the abbreviation for the + standard timezone; If DAYLIGHT?, then index 1 has the abbreviation + for the Daylight Savings timezone. + + +File: slib.info, Node: Posix Time, Next: Common-Lisp Time, Prev: Time Zone, Up: Time and Date + +Posix Time +---------- + + (require 'posix-time) + + - Data Type: Calendar-Time + is a datatype encapsulating time. + + - Data Type: Coordinated Universal Time + (abbreviated "UTC") is a vector of integers representing time: + + 0. seconds (0 - 61) + + 1. minutes (0 - 59) + + 2. hours since midnight (0 - 23) + + 3. day of month (1 - 31) + + 4. month (0 - 11). Note difference from + `decode-universal-time'. + + 5. the number of years since 1900. Note difference from + `decode-universal-time'. + + 6. day of week (0 - 6) + + 7. day of year (0 - 365) + + 8. 1 for daylight savings, 0 for regular time + + - Function: gmtime caltime + Converts the calendar time CALTIME to UTC and returns it. + + - Function: localtime caltime tz + Returns CALTIME converted to UTC relative to timezone TZ. + + - 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 (*note + tzset: Time Zone.). + + + - Function: gmktime univtime + Converts a vector of integers in GMT Coordinated Universal Time + (UTC) format to a calendar time. + + - Function: mktime univtime + Converts a vector of integers in local Coordinated Universal Time + (UTC) format to a calendar time. + + - Function: mktime univtime tz + Converts a vector of integers in Coordinated Universal Time (UTC) + format (relative to time-zone TZ) to calendar time. + + - 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: gtime caltime + - Function: ctime caltime + - Function: ctime caltime tz + Equivalent to `(asctime (gmtime CALTIME))', `(asctime (localtime + CALTIME))', and `(asctime (localtime CALTIME TZ))', respectively. + + +File: slib.info, Node: Common-Lisp Time, Prev: Posix Time, Up: Time and Date + +Common-Lisp Time +---------------- + + - 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.). Note difference from `gmtime' and `localtime'. + + 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: Vector Graphics, Next: Schmooz, Prev: Time and Date, Up: Textual Conversion Packages + +Vector Graphics +=============== + +* Menu: + +* Tektronix Graphics Support:: + + +File: slib.info, Node: Tektronix Graphics Support, Prev: Vector Graphics, Up: Vector Graphics + +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: Schmooz, Prev: Vector Graphics, Up: Textual Conversion Packages + +Schmooz +======= + + "Schmooz" is a simple, lightweight markup language for interspersing +Texinfo documentation with Scheme source code. Schmooz does not create +the top level Texinfo file; it creates `txi' files which can be +imported into the documentation using the Texinfo command `@include'. + + `(require 'schmooz)' defines the function `schmooz', which is used to +process files. Files containing schmooz documentation should not +contain `(require 'schmooz)'. + + - Procedure: schmooz filenamescm ... + FILENAMEscm should be a string ending with `scm' naming an + existing file containing Scheme source code. `schmooz' extracts + top-level comments containing schmooz commands from FILENAMEscm + and writes the converted Texinfo source to a file named + FILENAMEtxi. + + - Procedure: schmooz filenametexi ... + - Procedure: schmooz filenametex ... + - Procedure: schmooz filenametxi ... + FILENAME should be a string naming an existing file containing + Texinfo source code. For every occurrence of the string `@include + FILENAMEtxi' within that file, `schmooz' calls itself with the + argument `FILENAMEscm'. + + Schmooz comments are distinguished (from non-schmooz comments) by +their first line, which must start with an at-sign (@) preceded by one +or more semicolons (;). A schmooz comment ends at the first subsequent +line which does _not_ start with a semicolon. Currently schmooz +comments are recognized only at top level. + + Schmooz comments are copied to the Texinfo output file with the +leading contiguous semicolons removed. Certain character sequences +starting with at-sign are treated specially. Others are copied +unchanged. + + A schmooz comment starting with `@body' must be followed by a Scheme +definition. All comments between the `@body' line and the definition +will be included in a Texinfo definition, either a `@defun' or a +`@defvar', depending on whether a procedure or a variable is being +defined. + + Within the text of that schmooz comment, at-sign followed by `0' will +be replaced by `@code{procedure-name}' if the following definition is +of a procedure; or `@var{variable}' if defining a variable. + + An at-sign followed by a non-zero digit will expand to the variable +citation of that numbered argument: `@var{argument-name}'. + + If more than one definition follows a `@body' comment line without an +intervening blank or comment line, then those definitions will be +included in the same Texinfo definition using `@defvarx' or `@defunx', +depending on whether the first definition is of a variable or of a +procedure. + + Schmooz can figure out whether a definition is of a procedure if it +is of the form: + + `(define (<identifier> <arg> ...) <expression>)' + +or if the left hand side of the definition is some form ending in a +lambda expression. Obviously, it can be fooled. In order to force +recognition of a procedure definition, start the documentation with +`@args' instead of `@body'. `@args' should be followed by the argument +list of the function being defined, which may be enclosed in +parentheses and delimited by whitespace, (as in Scheme), enclosed in +braces and separated by commas, (as in Texinfo), or consist of the +remainder of the line, separated by whitespace. + + For example: + + ;;@args arg1 args ... + ;;@0 takes argument @1 and any number of @2 + (define myfun (some-function-returning-magic)) + + Will result in: + + @defun myfun arg1 args @dots{} + + @code{myfun} takes argument @var{arg1} and any number of @var{args} + @end defun + + `@args' may also be useful for indicating optional arguments by name. +If `@args' occurs inside a schmooz comment section, rather than at the +beginning, then it will generate a `@defunx' line with the arguments +supplied. + + If the first at-sign in a schmooz comment is immediately followed by +whitespace, then the comment will be expanded to whatever follows that +whitespace. If the at-sign is followed by a non-whitespace character +then the at-sign will be included as the first character of the +expansion. This feature is intended to make it easy to include Texinfo +directives in schmooz comments. + + +File: slib.info, Node: Mathematical Packages, Next: Database Packages, Prev: Textual Conversion Packages, Up: Top + +Mathematical Packages +********************* + +* Menu: + +* Bit-Twiddling:: 'logical +* Modular Arithmetic:: 'modular +* Prime Numbers:: 'factor +* Random Numbers:: 'random +* Fast Fourier Transform:: 'fft +* Cyclic Checksum:: 'make-crc +* Plotting:: 'charplot +* Root Finding:: 'root +* Minimizing:: 'minimize +* Commutative Rings:: 'commutative-ring +* Determinant:: 'determinant + + +File: slib.info, Node: Bit-Twiddling, Next: Modular Arithmetic, Prev: Mathematical Packages, Up: Mathematical Packages + +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. These functions +behave as though operating on integers in two's-complement +representation. + +Bitwise Operations +------------------ + + - 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: bitwise-if mask n0 n1 + Returns an integer composed of some bits from integer N0 and some + from integer N1. A bit of the result is taken from N0 if the + corresponding bit of integer MASK is 1 and from N1 if that bit of + MASK is 0. + + - Function: logtest j k + (logtest j k) == (not (zero? (logand j k))) + + (logtest #b0100 #b1011) => #f + (logtest #b0100 #b0111) => #t + + - 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 + +Bit Within Word +--------------- + + - 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: copy-bit index from bit + Returns an integer the same as FROM except in the INDEXth bit, + which is 1 if BIT is `#t' and 0 if BIT is `#f'. + + Example: + (number->string (copy-bit 0 0 #t) 2) => "1" + (number->string (copy-bit 2 0 #t) 2) => "100" + (number->string (copy-bit 2 #b1111 #f) 2) => "1011" + +Fields of Bits +-------------- + + - Function: bit-field 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. + + This function was called `bit-extract' in previous versions of + SLIB. + + Example: + (number->string (bit-field #b1101101010 0 4) 2) + => "1010" + (number->string (bit-field #b1101101010 4 9) 2) + => "10110" + + - Function: copy-bit-field to start end from + Returns an integer the same as TO except possibly in the START + (inclusive) through END (exclusive) bits, which are the same as + those of FROM. The 0-th bit of FROM becomes the STARTth bit of + the result. + + Example: + (number->string (copy-bit-field #b1101101010 0 4 0) 2) + => "1101100000" + (number->string (copy-bit-field #b1101101010 0 4 -1) 2) + => "1101101111" + + - 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: 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 + + +File: slib.info, Node: Modular Arithmetic, Next: Prime Numbers, Prev: Bit-Twiddling, Up: Mathematical Packages + +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 Numbers, Next: Random Numbers, Prev: Modular Arithmetic, Up: Mathematical Packages + +Prime Numbers +============= + + `(require 'factor)' + + - Variable: prime:prngs + PRIME:PRNGS is the random-state (*note Random Numbers::) used by + these procedures. If you call these procedures from more than one + thread (or from interrupt), `random' may complain about reentrant + calls. + _Note:_ The prime test and generation procedures implement (or use) +the Solovay-Strassen primality test. 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. + + - Variable: prime:trials + PRIME:TRIALS the maxinum number of iterations of Solovay-Strassen + that will be done to test a number for primality. + + - Function: prime? n + Returns `#f' if N is composite; `#t' if N is prime. There is a + slight chance `(expt 2 (- prime:trials))' that a composite will + return `#t'. + + - Function: primes< start count + Returns a list of the first COUNT prime numbers less than START. + If there are fewer than COUNT prime numbers less than START, then + the returned list will have fewer than START elements. + + - Function: primes> start count + Returns a list of the first COUNT prime numbers greater than START. + + - 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) <)'. + + +File: slib.info, Node: Random Numbers, Next: Fast Fourier Transform, Prev: Prime Numbers, Up: Mathematical Packages + +Random Numbers +============== + + `(require 'random)' + + A pseudo-random number generator is only as good as the tests it +passes. George Marsaglia of Florida State University developed a +battery of tests named "DIEHARD" +(<http://stat.fsu.edu/~geo/diehard.html>). `diehard.c' has a bug which +the patch +<http://swissnet.ai.mit.edu/ftpdir/users/jaffer/diehard.c.pat> corrects. + + SLIB's new PRNG generates 8 bits at a time. With the degenerate seed +`0', the numbers generated pass DIEHARD; but when bits are combined +from sequential bytes, tests fail. With the seed +`http://swissnet.ai.mit.edu/~jaffer/SLIB.html', all of those tests pass. + + - Function: random n + - Function: 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 by `random' are uniformly distributed from 0 to N. + + The optional argument STATE must be of the type returned by + `(seed->random-state)' or `(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 calls to `random'. + + - 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. + + - Function: copy-random-state state + Returns a new copy of argument STATE. + + - Function: copy-random-state + Returns a new copy of `*random-state*'. + + - Function: seed->random-state seed + Returns a new object of type suitable for use as the value of the + variable `*random-state*' or as a second argument to `random'. + The number or string SEED is used to initialize the state. If + `seed->random-state' is called twice with arguments which are + `equal?', then the returned data structures will be `equal?'. + Calling `seed->random-state' with unequal arguments will nearly + always return unequal states. + + - Function: make-random-state + - Function: make-random-state obj + Returns a new object of type suitable for use as the value of the + variable `*random-state*' or as a second argument to `random'. If + the optional argument OBJ is given, it should be a printable + Scheme object; the first 50 characters of its printed + representation will be used as the seed. Otherwise the value of + `*random-state*' is used as the seed. + + If inexact numbers are supported by the Scheme implementation, +`randinex.scm' will be loaded as well. `randinex.scm' contains +procedures for generating inexact distributions. + + - Function: random:uniform + - Function: random:uniform state + Returns an uniformly distributed inexact real random number in the + range between 0 and 1. + + - Function: random:exp + - Function: 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))'. + + - Function: random:normal + - Function: 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)))'. + + - Function: random:normal-vector! vect + - Function: 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). + + - Function: random:hollow-sphere! vect + - Function: 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. + + - Function: random:solid-sphere! vect + - Function: 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. + + +File: slib.info, Node: Fast Fourier Transform, Next: Cyclic Checksum, Prev: Random Numbers, Up: Mathematical Packages + +Fast Fourier Transform +====================== + + `(require 'fft)' + + - Function: fft array + ARRAY is an array of `(expt 2 n)' numbers. `fft' returns an array + of complex numbers comprising the "Discrete Fourier Transform" of + ARRAY. + + - Function: fft-1 array + `fft-1' returns an array of complex numbers comprising the inverse + Discrete Fourier Transform of ARRAY. + + `(fft-1 (fft ARRAY))' will return an array of values close to ARRAY. + + (fft '#(1 0+i -1 0-i 1 0+i -1 0-i)) => + + #(0.0 0.0 0.0+628.0783185208527e-18i 0.0 + 0.0 0.0 8.0-628.0783185208527e-18i 0.0) + + (fft-1 '#(0 0 0 0 0 0 8 0)) => + + #(1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i + 1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i) + + +File: slib.info, Node: Cyclic Checksum, Next: Plotting, Prev: Fast Fourier Transform, Up: Mathematical Packages + +Cyclic Checksum +=============== + + `(require 'make-crc)' + + - Function: make-port-crc + - Function: make-port-crc degree | + 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. + + - Function: make-port-crc generator | + 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 value of GENERATOR must be larger than 127. | + | + - Function: make-port-crc degree generator | + 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")) + + => 157103930 | + + +File: slib.info, Node: Plotting, Next: Root Finding, Prev: Cyclic Checksum, Up: Mathematical Packages + +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|- **** | + | ** ** | + 0.75|- * * | + | * * | + 0.5|- * * | + | * | + 0.25|- * | + | * * | + 0|-------------------*--------------------------| + | * | + -0.25|- * * | + | * * | + -0.5|- * | + | * * | + -0.75|- * * | + | ** ** | + -1|- **** | + |____________:_____._____:_____._____:_________| + x 2 4 6 + + - Procedure: plot-function! func x1 x2 + - Procedure: plot-function! func x1 x2 npts + Plots the function of one argument FUNC over the range X1 to X2. + If the optional integer argument NPTS is supplied, it specifies + the number of points to evaluate FUNC at. + + +File: slib.info, Node: Root Finding, Next: Minimizing, Prev: Plotting, Up: Mathematical Packages + +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. + + - Function: secant:find-root f x0 x1 prec + - Function: secant:find-bracketed-root f x0 x1 prec + Given a real valued procedure F and two real valued starting + points X0 and X1, 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 X0 and X1 are chosen such that they bracket a root, that is + (or (< (f x0) 0 (f x1)) + (< (f x1) 0 (f x0))) + then the root returned will be between X0 and X1, and F will not + be passed an argument outside of that interval. + + `secant:find-bracketed-root' will return `#f' unless X0 and X1 + bracket a root. + + The secant method is used until a bracketing interval is found, at + which point a modified regula falsi method is used. + + If PREC is instead a negative integer, `secant:find-root' returns + the result of -PREC iterations. + + If PREC is a procedure it should accept 5 arguments: X0 F0 X1 F1 + and COUNT, where F0 will be `(f x0)', F1 `(f x1)', and COUNT the + number of iterations performed so far. PREC should return + non-false if the iteration should be stopped. + + +File: slib.info, Node: Minimizing, Next: Commutative Rings, Prev: Root Finding, Up: Mathematical Packages + +Minimizing +========== + + `(require 'minimize)' + +The Golden Section Search (1) algorithm finds minima of functions which +are expensive to compute or for which derivatives are not available. +Although optimum for the general case, convergence is slow, requiring +nearly 100 iterations for the example (x^3-2x-5). + +If the derivative is available, Newton-Raphson is probably a better +choice. If the function is inexpensive to compute, consider +approximating the derivative. + + - Function: golden-section-search f x0 x1 prec + X_0 are X_1 real numbers. The (single argument) procedure F is + unimodal over the open interval (X_0, X_1). That is, there is + exactly one point in the interval for which the derivative of F is + zero. + + `golden-section-search' returns a pair (X . F(X)) where F(X) is + the minimum. The PREC parameter is the stop criterion. If PREC + is a positive number, then the iteration continues until X is + within PREC from the true value. If PREC is a negative integer, + then the procedure will iterate -PREC times or until convergence. + If PREC is a procedure of seven arguments, X0, X1, A, B, FA, FB, + and COUNT, then the iterations will stop when the procedure + returns `#t'. + + Analytically, the minimum of x^3-2x-5 is 0.816497. + (define func (lambda (x) (+ (* x (+ (* x x) -2)) -5))) + (golden-section-search func 0 1 (/ 10000)) + ==> (816.4883855245578e-3 . -6.0886621077391165) + (golden-section-search func 0 1 -5) + ==> (819.6601125010515e-3 . -6.088637561916407) + (golden-section-search func 0 1 + (lambda (a b c d e f g ) (= g 500))) + ==> (816.4965933140557e-3 . -6.088662107903635) + + ---------- Footnotes ---------- + + (1) David Kahaner, Cleve Moler, and Stephen Nash `Numerical Methods +and Software' Prentice-Hall, 1989, ISBN 0-13-627258-4 + + +File: slib.info, Node: Commutative Rings, Next: Determinant, Prev: Minimizing, Up: Mathematical Packages + +Commutative Rings +================= + + Scheme provides a consistent and capable set of numeric functions. +Inexacts implement a field; integers a commutative ring (and Euclidean +domain). This package allows one to use basic Scheme numeric functions +with symbols and non-numeric elements of commutative rings. + + `(require 'commutative-ring)' + + The "commutative-ring" package makes the procedures `+', `-', `*', +`/', and `^' "careful" in the sense that any non-numeric arguments they +do not reduce appear in the expression output. In order to see what +working with this package is like, self-set all the single letter +identifiers (to their corresponding symbols). + + (define a 'a) + ... + (define z 'z) + + Or just `(require 'self-set)'. Now try some sample expressions: + + (+ (+ a b) (- a b)) => (* a 2) + (* (+ a b) (+ a b)) => (^ (+ a b) 2) + (* (+ a b) (- a b)) => (* (+ a b) (- a b)) + (* (- a b) (- a b)) => (^ (- a b) 2) + (* (- a b) (+ a b)) => (* (+ a b) (- a b)) + (/ (+ a b) (+ c d)) => (/ (+ a b) (+ c d)) + (^ (+ a b) 3) => (^ (+ a b) 3) + (^ (+ a 2) 3) => (^ (+ 2 a) 3) + + Associative rules have been applied and repeated addition and +multiplication converted to multiplication and exponentiation. + + We can enable distributive rules, thus expanding to sum of products +form: + (set! *ruleset* (combined-rulesets distribute* distribute/)) + + (* (+ a b) (+ a b)) => (+ (* 2 a b) (^ a 2) (^ b 2)) + (* (+ a b) (- a b)) => (- (^ a 2) (^ b 2)) + (* (- a b) (- a b)) => (- (+ (^ a 2) (^ b 2)) (* 2 a b)) + (* (- a b) (+ a b)) => (- (^ a 2) (^ b 2)) + (/ (+ a b) (+ c d)) => (+ (/ a (+ c d)) (/ b (+ c d))) + (/ (+ a b) (- c d)) => (+ (/ a (- c d)) (/ b (- c d))) + (/ (- a b) (- c d)) => (- (/ a (- c d)) (/ b (- c d))) + (/ (- a b) (+ c d)) => (- (/ a (+ c d)) (/ b (+ c d))) + (^ (+ a b) 3) => (+ (* 3 a (^ b 2)) (* 3 b (^ a 2)) (^ a 3) (^ b 3)) + (^ (+ a 2) 3) => (+ 8 (* a 12) (* (^ a 2) 6) (^ a 3)) + + Use of this package is not restricted to simple arithmetic +expressions: + + (require 'determinant) + + (determinant '((a b c) (d e f) (g h i))) => + (- (+ (* a e i) (* b f g) (* c d h)) (* a f h) (* b d i) (* c e g)) + + Currently, only `+', `-', `*', `/', and `^' support non-numeric +elements. Expressions with `-' are converted to equivalent expressions +without `-', so behavior for `-' is not defined separately. `/' +expressions are handled similarly. + + This list might be extended to include `quotient', `modulo', +`remainder', `lcm', and `gcd'; but these work only for the more +restrictive Euclidean (Unique Factorization) Domain. + +Rules and Rulesets +================== + + The "commutative-ring" package allows control of ring properties +through the use of "rulesets". + + - Variable: *ruleset* + Contains the set of rules currently in effect. Rules defined by + `cring:define-rule' are stored within the value of *ruleset* at the + time `cring:define-rule' is called. If *RULESET* is `#f', then no + rules apply. + + - Function: make-ruleset rule1 ... + - Function: make-ruleset name rule1 ... + Returns a new ruleset containing the rules formed by applying + `cring:define-rule' to each 4-element list argument RULE. If the + first argument to `make-ruleset' is a symbol, then the database + table created for the new ruleset will be named NAME. Calling + `make-ruleset' with no rule arguments creates an empty ruleset. + + - Function: combined-rulesets ruleset1 ... + - Function: combined-rulesets name ruleset1 ... + Returns a new ruleset containing the rules contained in each + ruleset argument RULESET. If the first argument to + `combined-ruleset' is a symbol, then the database table created for + the new ruleset will be named NAME. Calling `combined-ruleset' + with no ruleset arguments creates an empty ruleset. + + Two rulesets are defined by this package. + + - Constant: distribute* + Contain the ruleset to distribute multiplication over addition and + subtraction. + + - Constant: distribute/ + Contain the ruleset to distribute division over addition and + subtraction. + + Take care when using both DISTRIBUTE* and DISTRIBUTE/ + simultaneously. It is possible to put `/' into an infinite loop. + + You can specify how sum and product expressions containing non-numeric +elements simplify by specifying the rules for `+' or `*' for cases +where expressions involving objects reduce to numbers or to expressions +involving different non-numeric elements. + + - Function: cring:define-rule op sub-op1 sub-op2 reduction + Defines a rule for the case when the operation represented by + symbol OP is applied to lists whose `car's are SUB-OP1 and + SUB-OP2, respectively. The argument REDUCTION is a procedure + accepting 2 arguments which will be lists whose `car's are SUB-OP1 + and SUB-OP2. + + - Function: cring:define-rule op sub-op1 'identity reduction + Defines a rule for the case when the operation represented by + symbol OP is applied to a list whose `car' is SUB-OP1, and some + other argument. REDUCTION will be called with the list whose + `car' is SUB-OP1 and some other argument. + + If REDUCTION returns `#f', the reduction has failed and other + reductions will be tried. If REDUCTION returns a non-false value, + that value will replace the two arguments in arithmetic (`+', `-', + and `*') calculations involving non-numeric elements. + + The operations `+' and `*' are assumed commutative; hence both + orders of arguments to REDUCTION will be tried if necessary. + + The following rule is the definition for distributing `*' over `+'. + + (cring:define-rule + '* '+ 'identity + (lambda (exp1 exp2) + (apply + (map (lambda (trm) (* trm exp2)) (cdr exp1)))))) + +How to Create a Commutative Ring +================================ + + The first step in creating your commutative ring is to write +procedures to create elements of the ring. A non-numeric element of +the ring must be represented as a list whose first element is a symbol +or string. This first element identifies the type of the object. A +convenient and clear convention is to make the type-identifying element +be the same symbol whose top-level value is the procedure to create it. + + (define (n . list1) + (cond ((and (= 2 (length list1)) + (eq? (car list1) (cadr list1))) + 0) + ((not (term< (first list1) (last1 list1))) + (apply n (reverse list1))) + (else (cons 'n list1)))) + + (define (s x y) (n x y)) + + (define (m . list1) + (cond ((neq? (first list1) (term_min list1)) + (apply m (cyclicrotate list1))) + ((term< (last1 list1) (cadr list1)) + (apply m (reverse (cyclicrotate list1)))) + (else (cons 'm list1)))) + + Define a procedure to multiply 2 non-numeric elements of the ring. +Other multiplicatons are handled automatically. Objects for which rules +have _not_ been defined are not changed. + + (define (n*n ni nj) + (let ((list1 (cdr ni)) (list2 (cdr nj))) + (cond ((null? (intersection list1 list2)) #f) + ((and (eq? (last1 list1) (first list2)) + (neq? (first list1) (last1 list2))) + (apply n (splice list1 list2))) + ((and (eq? (first list1) (first list2)) + (neq? (last1 list1) (last1 list2))) + (apply n (splice (reverse list1) list2))) + ((and (eq? (last1 list1) (last1 list2)) + (neq? (first list1) (first list2))) + (apply n (splice list1 (reverse list2)))) + ((and (eq? (last1 list1) (first list2)) + (eq? (first list1) (last1 list2))) + (apply m (cyclicsplice list1 list2))) + ((and (eq? (first list1) (first list2)) + (eq? (last1 list1) (last1 list2))) + (apply m (cyclicsplice (reverse list1) list2))) + (else #f)))) + + Test the procedures to see if they work. + + ;;; where cyclicrotate(list) is cyclic rotation of the list one step + ;;; by putting the first element at the end + (define (cyclicrotate list1) + (append (rest list1) (list (first list1)))) + ;;; and where term_min(list) is the element of the list which is + ;;; first in the term ordering. + (define (term_min list1) + (car (sort list1 term<))) + (define (term< sym1 sym2) + (string<? (symbol->string sym1) (symbol->string sym2))) + (define first car) + (define rest cdr) + (define (last1 list1) (car (last-pair list1))) + (define (neq? obj1 obj2) (not (eq? obj1 obj2))) + ;;; where splice is the concatenation of list1 and list2 except that their + ;;; common element is not repeated. + (define (splice list1 list2) + (cond ((eq? (last1 list1) (first list2)) + (append list1 (cdr list2))) + (else (error 'splice list1 list2)))) + ;;; where cyclicsplice is the result of leaving off the last element of + ;;; splice(list1,list2). + (define (cyclicsplice list1 list2) + (cond ((and (eq? (last1 list1) (first list2)) + (eq? (first list1) (last1 list2))) + (butlast (splice list1 list2) 1)) + (else (error 'cyclicsplice list1 list2)))) + + (N*N (S a b) (S a b)) => (m a b) + + Then register the rule for multiplying type N objects by type N +objects. + + (cring:define-rule '* 'N 'N N*N)) + + Now we are ready to compute! + + (define (t) + (define detM + (+ (* (S g b) + (+ (* (S f d) + (- (* (S a f) (S d g)) (* (S a g) (S d f)))) + (* (S f f) + (- (* (S a g) (S d d)) (* (S a d) (S d g)))) + (* (S f g) + (- (* (S a d) (S d f)) (* (S a f) (S d d)))))) + (* (S g d) + (+ (* (S f b) + (- (* (S a g) (S d f)) (* (S a f) (S d g)))) + (* (S f f) + (- (* (S a b) (S d g)) (* (S a g) (S d b)))) + (* (S f g) + (- (* (S a f) (S d b)) (* (S a b) (S d f)))))) + (* (S g f) + (+ (* (S f b) + (- (* (S a d) (S d g)) (* (S a g) (S d d)))) + (* (S f d) + (- (* (S a g) (S d b)) (* (S a b) (S d g)))) + (* (S f g) + (- (* (S a b) (S d d)) (* (S a d) (S d b)))))) + (* (S g g) + (+ (* (S f b) + (- (* (S a f) (S d d)) (* (S a d) (S d f)))) + (* (S f d) + (- (* (S a b) (S d f)) (* (S a f) (S d b)))) + (* (S f f) + (- (* (S a d) (S d b)) (* (S a b) (S d d)))))))) + (* (S b e) (S c a) (S e c) + detM + )) + (pretty-print (t)) + -| + (- (+ (m a c e b d f g) + (m a c e b d g f) + (m a c e b f d g) + (m a c e b f g d) + (m a c e b g d f) + (m a c e b g f d)) + (* 2 (m a b e c) (m d f g)) + (* (m a c e b d) (m f g)) + (* (m a c e b f) (m d g)) + (* (m a c e b g) (m d f))) + + +File: slib.info, Node: Determinant, Prev: Commutative Rings, Up: Mathematical Packages + +Determinant +=========== + + - Function: determinant square-matrix | + Returns the determinant of SQUARE-MATRIX. | + | + (require 'determinant) + (determinant '((1 2) (3 4))) => -2 + (determinant '((1 2 3) (4 5 6) (7 8 9))) => 0 + (determinant '((1 2 3 4) (5 6 7 8) (9 10 11 12))) => 0 + + +File: slib.info, Node: Database Packages, Next: Other Packages, Prev: Mathematical Packages, Up: Top + +Database Packages +***************** + +* Menu: + +* Base Table:: +* Relational Database:: 'relational-database +* Weight-Balanced Trees:: 'wt-tree + + +File: slib.info, Node: Base Table, Next: Relational Database, Prev: Database Packages, Up: Database Packages + +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. + +In contrast, a MATCH-KEYS argument is a list of length equal to the +number of primary keys. The MATCH-KEYS restrict the actions of the +table command to those records whose primary keys all satisfy the +corresponding element of the MATCH-KEYS list. The elements and their +actions are: + + `#f' + The false value matches any key in the corresponding position. + + an object of type procedure + This procedure must take a single argument, the key in the + corresponding position. Any key for which the procedure + returns a non-false value is a match; Any key for which the + procedure returns a `#f' is not. + + other values + Any other value matches only those keys `equal?' to it. + +The KEY-DIMENSION and COLUMN-TYPES arguments are needed to decode the +combined-keys for matching with MATCH-KEYS. + + - Function: for-each-key handle procedure key-dimension column-types + match-keys + Calls PROCEDURE once with each KEY in the table opened in HANDLE + which satisfy MATCH-KEYS in an unspecified order. An unspecified + value is returned. + + - Function: map-key handle procedure key-dimension column-types + match-keys + Returns a list of the values returned by calling PROCEDURE once + with each KEY in the table opened in HANDLE which satisfy + MATCH-KEYS in an unspecified order. + + - Function: ordered-for-each-key handle procedure key-dimension + column-types match-keys + Calls PROCEDURE once with each KEY in the table opened in HANDLE + which satisfy MATCH-KEYS in the natural order for the types of the + primary key fields of that table. An unspecified value is + returned. + + - Function: delete* handle key-dimension column-types match-keys + Removes all rows which satisfy MATCH-KEYS from the table opened in + HANDLE. 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: Database Packages + +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 +* Database Reports:: +* Database Browser:: 'database-browse + + +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 conscientious 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: sync-database | + Causes any pending updates to the database file to be written out. | + 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)) + +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 must not be +missing. + + - Function: get column-name + Returns a procedure of arguments KEY1 KEY2 ... which returns the + value for the COLUMN-NAME column of the row associated with + primary keys KEY1, KEY2 ... if that row exists in the table, or + `#f' otherwise. + + ((plat 'get 'processor) 'djgpp) => i386 + ((plat 'get 'processor) 'be-os) => #f + + - Function: get* column-name + Returns a procedure of optional arguments MATCH-KEY1 ... which + returns a list of the values for the specified column for all rows + in this table. The optional MATCH-KEY1 ... arguments restrict + actions to a subset of the table. See the match-key description + below for details. + + ((plat 'get* 'processor)) => + (i386 8086 i386 8086 i386 i386 8086 m68000 + m68000 m68000 m68000 m68000 powerpc) + + ((plat 'get* 'processor) #f) => + (i386 8086 i386 8086 i386 i386 8086 m68000 + m68000 m68000 m68000 m68000 powerpc) + + (define (a-key? key) + (char=? #\a (string-ref (symbol->string key) 0))) + + ((plat 'get* 'processor) a-key?) => + (m68000 m68000 m68000 m68000 m68000 powerpc) + + ((plat 'get* 'name) a-key?) => + (atari-st-turbo-c atari-st-gcc amiga-sas/c-5.10 + amiga-aztec amiga-dice-c aix) + + - Function: row:retrieve + Returns a procedure of arguments KEY1 KEY2 ... which returns the + row associated with primary keys KEY1, KEY2 ... if it exists, or + `#f' otherwise. + + ((plat 'row:retrieve) 'linux) => (linux i386 linux gcc) + ((plat 'row:retrieve) 'multics) => #f + + - Function: row:retrieve* + Returns a procedure of optional arguments MATCH-KEY1 ... which + returns a list of all rows in this table. The optional MATCH-KEY1 + ... arguments restrict actions to a subset of the table. See the + match-key description below for details. + + ((plat 'row:retrieve*) a-key?) => + ((atari-st-turbo-c m68000 atari turbo-c) + (atari-st-gcc m68000 atari gcc) + (amiga-sas/c-5.10 m68000 amiga sas/c) + (amiga-aztec m68000 amiga aztec) + (amiga-dice-c m68000 amiga dice-c) + (aix powerpc aix -)) + + - Function: row:remove + Returns a procedure of arguments KEY1 KEY2 ... which removes and + returns the row associated with primary keys KEY1, KEY2 ... if it + exists, or `#f' otherwise. + + - Function: row:remove* + Returns a procedure of optional arguments MATCH-KEY1 ... which + removes and returns a list of all rows in this table. The optional + MATCH-KEY1 ... arguments restrict actions to a subset of the + table. See the match-key description below for details. + + - Function: row:delete + Returns a procedure of arguments KEY1 KEY2 ... which deletes the + row associated with primary keys KEY1, KEY2 ... if it exists. The + value returned is unspecified. + + - Function: row:delete* + Returns a procedure of optional arguments MATCH-KEY1 ... which + Deletes all rows from this table. The optional MATCH-KEY1 ... + arguments restrict deletions to a subset of the table. See the + match-key description below for details. The value returned is + unspecified. The descriptor table and catalog entry for this + table are not affected. + + - Function: row:update + Returns a procedure of one argument, ROW, which 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* + Returns a procedure of one argument, ROWS, which adds each row in + the list of rows, 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 + 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* + Returns a procedure of one argument, ROWS, which adds each row in + the list of rows, 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 + Returns a procedure of arguments PROC MATCH-KEY1 ... which calls + PROC with each ROW in this table in the (implementation-dependent) + natural ordering for rows. The optional MATCH-KEY1 ... arguments + restrict actions to a subset of the table. See the match-key + description below for details. + + _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. + +The (optional) MATCH-KEY1 ... arguments are used to restrict actions of +a whole-table operation to a subset of that table. Those procedures +(returned by methods) which accept match-key arguments will accept any +number of match-key arguments between zero and the number of primary +keys in the table. Any unspecified MATCH-KEY arguments default to `#f'. + +The MATCH-KEY1 ... restrict the actions of the table command to those +records whose primary keys each satisfy the corresponding MATCH-KEY +argument. The arguments and their actions are: + + `#f' + The false value matches any key in the corresponding position. + + an object of type procedure + This procedure must take a single argument, the key in the + corresponding position. Any key for which the procedure + returns a non-false value is a match; Any key for which the + procedure returns a `#f' is not. + + other values + Any other value matches only those keys `equal?' to it. + + - 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; thus they would + require locks in order to operate properly in a multiprocess + environment. Are all examples of utilities whose state should not + be part of transactions also non-reentrant? If so, perhaps + suspending transaction capture for the duration of locks would + solve this problem. + + +File: slib.info, Node: Database Utilities, Next: Database Reports, 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 + defaulter expression + expander 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 `defaulter' field is an expression whose value is either `#f' or +a procedure of one argument (the parameter-list) which returns a _list_ +of the default value or values as appropriate. Note that since the +`defaulter' 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. + + TYPES + A list of the type name of each parameter. Correspnds to the + `type-id' field of the contents of the `domain' of the + COMMAND's parameter-table. + + DEFAULTERS + A list of the defaulters for each parameter. Corresponds to + the `defaulters' 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 'fluid-let) + (require 'parameters) + (require 'getopt) + + (define my-rdb (create-database #f 'alist-table)) + + (define-tables my-rdb + '(foo-params + *parameter-columns* + *parameter-columns* + ((1 single-string single string + (lambda (pl) '("str")) #f "single string") + (2 nary-symbols nary symbol + (lambda (pl) '()) #f "zero or more symbols") + (3 nary1-symbols nary1 symbol + (lambda (pl) '(symb)) #f "one or more symbols") + (4 optional-number optional uint + (lambda (pl) '()) #f "zero or one number") + (5 flag boolean boolean + (lambda (pl) '(#f)) #f "a boolean flag"))) + '(foo-pnames + ((name string)) + ((parameter-index uint)) + (("s" 1) + ("single-string" 1) + ("n" 2) + ("nary-symbols" 2) + ("N" 3) + ("nary1-symbols" 3) + ("o" 4) + ("optional-number" 4) + ("f" 5) + ("flag" 5))) + '(my-commands + ((name symbol)) + ((parameters parameter-list) + (parameter-names parameter-name-translation) + (procedure expression) + (documentation string)) + ((foo + foo-params + foo-pnames + (lambda (rdb) (lambda args (print args))) + "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 defaulters dirs aliases) + (apply comval (getopt->arglist + argc argv options positions + arities types defaulters dirs aliases))))) + + (define (cmd . opts) + (fluid-let ((*optind* 1)) + (printf "%-34s => " + (call-with-output-string + (lambda (pt) (write (cons 'cmd opts) pt)))) + (set! opts (cons "cmd" opts)) + (force-output) + (dbutil:serve-command-line + my-rdb 'my-commands 'foo (length opts) opts))) + + (cmd) => ("str" () (symb) () #f) + (cmd "-f") => ("str" () (symb) () #t) + (cmd "--flag") => ("str" () (symb) () #t) + (cmd "-o177") => ("str" () (symb) (177) #f) + (cmd "-o" "177") => ("str" () (symb) (177) #f) + (cmd "--optional" "621") => ("str" () (symb) (621) #f) + (cmd "--optional=621") => ("str" () (symb) (621) #f) + (cmd "-s" "speciality") => ("speciality" () (symb) () #f) + (cmd "-sspeciality") => ("speciality" () (symb) () #f) + (cmd "--single" "serendipity") => ("serendipity" () (symb) () #f) + (cmd "--single=serendipity") => ("serendipity" () (symb) () #f) + (cmd "-n" "gravity" "piety") => ("str" () (piety gravity) () #f) + (cmd "-ngravity" "piety") => ("str" () (piety gravity) () #f) + (cmd "--nary" "chastity") => ("str" () (chastity) () #f) + (cmd "--nary=chastity" "") => ("str" () ( chastity) () #f) + (cmd "-N" "calamity") => ("str" () (calamity) () #f) + (cmd "-Ncalamity") => ("str" () (calamity) () #f) + (cmd "--nary1" "surety") => ("str" () (surety) () #f) + (cmd "--nary1=surety") => ("str" () (surety) () #f) + (cmd "-N" "levity" "fealty") => ("str" () (fealty levity) () #f) + (cmd "-Nlevity" "fealty") => ("str" () (fealty levity) () #f) + (cmd "--nary1" "surety" "brevity") => ("str" () (brevity surety) () #f) + (cmd "--nary1=surety" "brevity") => ("str" () (brevity surety) () #f) + (cmd "-?") + -| + Usage: cmd [OPTION ARGUMENT ...] ... + + -f, --flag + -o, --optional[=]<number> + -n, --nary[=]<symbols> ... + -N, --nary1[=]<symbols> ... + -s, --single[=]<string> + + ERROR: getopt->parameter-list "unrecognized option" "-?" + + 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::. Currently, these fields are + * domain-name + + * foreign-table + + * domain-integrity-rule + + * type-id + + * type-param + + The following example adds 3 domains to the `build' database. + `Optstring' is either a string or `#f'. `filename' is a string + and `build-whats' is a symbol. + + (for-each (build 'add-domain) + '((optstring #f + (lambda (x) (or (not x) (string? x))) + string + #f) + (filename #f #f string #f) + (build-whats #f #f symbol #f))) + + - 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 (which returns `#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. + +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 + +Listing Tables | +.............. | + | + - Procedure: list-table-definition rdb table-name | + If symbol TABLE-NAME exists in the open relational-database RDB, | + then returns a list of the table-name, its primary key names and | + domains, its other key names and domains, and the table's records | + (as lists). Otherwise, returns #f. | + | + The list returned by `list-table-definition', when passed as an | + argument to `define-tables', will recreate the table. | + | + +File: slib.info, Node: Database Reports, Next: Database Browser, Prev: Database Utilities, Up: Relational Database + +Database Reports +---------------- + +Code for generating database reports is in `report.scm'. After writing +it using `format', I discovered that Common-Lisp `format' is not +useable for this application because there is no mechanismm for +truncating fields. `report.scm' needs to be rewritten using `printf'. + + - 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*. + + 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. + + 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. + + +File: slib.info, Node: Database Browser, Prev: Database Reports, Up: Relational Database + +Database Browser +---------------- + + (require 'database-browse) + + - Procedure: browse database + Prints the names of all the tables in DATABASE and sets browse's + default to DATABASE. + + - Procedure: browse + Prints the names of all the tables in the default database. + + - Procedure: browse table-name + For each record of the table named by the symbol TABLE-NAME, + prints a line composed of all the field values. + + - Procedure: browse pathname + Opens the database named by the string PATHNAME, prints the names + of all its tables, and sets browse's default to the database. + + - Procedure: browse database table-name + Sets browse's default to DATABASE and prints the records of the + table named by the symbol TABLE-NAME. + + - Procedure: browse pathname table-name + Opens the database named by the string PATHNAME and sets browse's + default to it; `browse' prints the records of the table named by + the symbol TABLE-NAME. + + + +File: slib.info, Node: Weight-Balanced Trees, Prev: Relational Database, Up: Database Packages + +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: Other Packages, Next: About SLIB, Prev: Database Packages, Up: Top + +Other Packages +************** + +* Menu: + +* Data Structures:: Various data structures. +* Procedures:: Miscellaneous utility procedures. +* Standards Support:: Support for Scheme Standards. +* Session Support:: REPL and Debugging. +* Extra-SLIB Packages:: + + +File: slib.info, Node: Data Structures, Next: Procedures, Prev: Other Packages, Up: Other Packages + +Data Structures +=============== + +* Menu: + +* Arrays:: 'array +* Array Mapping:: 'array-for-each +* Association Lists:: 'alist +* Byte:: 'byte +* Portable Image Files:: 'pnm +* Collections:: 'collect +* Dynamic Data Type:: 'dynamic +* Hash Tables:: 'hash-table +* Hashing:: 'hash, 'sierpinski, 'soundex +* Object:: 'object +* Priority Queues:: 'priority-queue +* Queues:: 'queue +* Records:: 'record +* 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 index1 index2 + - Function: array-3d-ref array index1 index2 index3 + + - Procedure: array-1d-set! array new-value index + - Procedure: array-2d-set! array new-value index1 index2 + - Procedure: array-3d-set! array new-value index1 index2 index3 + + 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-index-map! array proc + applies PROC to the indices of each element of ARRAY in turn, + storing the result in the corresponding element. The value + returned and the order of application are unspecified. + + One can implement ARRAY-INDEXES as + (define (array-indexes array) + (let ((ra (apply make-array #f (array-shape array)))) + (array-index-map! ra (lambda x x)) + ra)) + Another example: + (define (apl:index-generator n) + (let ((v (make-uniform-vector n 1))) + (array-index-map! v (lambda (i) i)) + v)) + + - 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: Byte, 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: Byte, Next: Portable Image Files, Prev: Association Lists, Up: Data Structures + +Byte +---- + + `(require 'byte)' + + Some algorithms are expressed in terms of arrays of small integers. +Using Scheme strings to implement these arrays is not portable vis-a-vis +the correspondence between integers and characters and non-ascii +character sets. These functions abstract the notion of a "byte". + + - Function: byte-ref bytes k + K must be a valid index of BYTES. `byte-ref' returns byte K of + BYTES using zero-origin indexing. + + - Procedure: byte-set! bytes k byte + K must be a valid index of BYTES%, and BYTE must be a small + integer. `Byte-set!' stores BYTE in element K of BYTES and + returns an unspecified value. + + - Function: make-bytes k + - Function: make-bytes k byte + `Make-bytes' returns a newly allocated byte-array of length K. If + BYTE is given, then all elements of the byte-array are initialized + to BYTE, otherwise the contents of the byte-array are unspecified. + + + - Function: bytes-length bytes + `bytes-length' returns length of byte-array BYTES. + + + - Function: write-byte byte + - Function: write-byte byte port + Writes the byte BYTE (not an external representation of the byte) + to the given PORT and returns an unspecified value. The PORT + argument may be omitted, in which case it defaults to the value + returned by `current-output-port'. + + + - Function: read-byte + - Function: read-byte port + Returns the next byte available from the input PORT, updating the + PORT to point to the following byte. If no more bytes 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: bytes byte ... + Returns a newly allocated byte-array composed of the arguments. + + + - Function: bytes->list bytes + - Function: list->bytes bytes + `Bytes->list' returns a newly allocated list of the bytes that + make up the given byte-array. `List->bytes' returns a newly + allocated byte-array formed from the small integers in the list + BYTES. `Bytes->list' and `list->bytes' are inverses so far as + `equal?' is concerned. + + + +File: slib.info, Node: Portable Image Files, Next: Collections, Prev: Byte, Up: Data Structures + +Portable Image Files +-------------------- + + `(require 'pnm)' + + - Function: pnm:type-dimensions path + The string PATH must name a "portable bitmap graphics" file. + `pnm:type-dimensions' returns a list of 4 items: + 1. A symbol describing the type of the file named by PATH. + + 2. The image width in pixels. + + 3. The image height in pixels. + + 4. The maximum value of pixels assume in the file. + + The current set of file-type symbols is: + pbm + pbm-raw + Black-and-White image; pixel values are 0 or 1. + + pgm + pgm-raw + Gray (monochrome) image; pixel values are from 0 to MAXVAL + specified in file header. + + ppm + ppm-raw + RGB (full color) image; red, green, and blue interleaved + pixel values are from 0 to MAXVAL + + + - Function: pnm:image-file->array path array + Reads the "portable bitmap graphics" file named by PATH into + ARRAY. ARRAY must be the correct size and type for PATH. ARRAY + is returned. + + - Function: pnm:image-file->array path + `pnm:image-file->array' creates and returns an array with the + "portable bitmap graphics" file named by PATH read into it. + + + - Procedure: pnm:array-write type array maxval path + Writes the contents of ARRAY to a TYPE image file named PATH. The + file will have pixel values between 0 and MAXVAL, which must be + compatible with TYPE. For `pbm' files, MAXVAL must be `1'. + + + +File: slib.info, Node: Collections, Next: Dynamic Data Type, Prev: Portable Image Files, 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: Object, 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 languages. | + + 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: Object, Next: Priority Queues, Prev: Hashing, 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) + (let* ((self (make-object + (make-number 1) + (make-description "A number which can be inverted"))) + (<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 (x) (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: Priority Queues, Next: Queues, Prev: Object, 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. + + +File: slib.info, Node: Records, Next: Structures, 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. + + In May of 1996, as a product of discussion on the `rrrs-authors' +mailing list, I rewrote `record.scm' to portably implement type +disjointness for record data types. + + As long as an implementation's procedures are opaque and the `record' +code is loaded before other programs, this will give disjoint record +types which are unforgeable and incorruptible by R4RS procedures. + + As a consequence, the procedures `record?', `record-type-descriptor', +`record-type-name'.and `record-type-field-names' are no longer +supported. + + +File: slib.info, Node: Structures, Prev: Records, 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: Procedures, Next: Standards Support, Prev: Data Structures, Up: Other Packages + +Procedures +========== + + Anything that doesn't fall neatly into any of the other categories +winds up here. + +* Menu: + +* Common List Functions:: 'common-list-functions +* Tree Operations:: 'tree +* Type Coercion:: 'coerce | +* Chapter Ordering:: 'chapter-order +* Sorting:: 'sort +* Topological Sort:: Keep your socks on. +* String-Case:: 'string-case +* String Ports:: 'string-port +* String Search:: Also Search from a Port. +* Line I/O:: 'line-i/o +* Multi-Processing:: 'process +* Metric Units:: Portable manifest types for numeric values. | + + +File: slib.info, Node: Common List Functions, Next: Tree Operations, Prev: Procedures, 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 +............. + + `eqv?' is used to test for membership by procedures 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)) + => (4 3) | + (intersection '(1 2 3 4) '(5 6 7 8)) + => () + + - Function: set-difference l1 l2 + `set-difference' returns all elements that are in L1 but not in L2. + + Example: + (set-difference '(1 2 3 4) '(3 4 5 6)) + => (2 1) | + (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: list-of?? predicate | + Returns a predicate which returns true if its argument is a list | + every element of which satisfies PREDICATE. | + | + - Function: list-of?? predicate low-bound high-bound | + LOW-BOUND and HIGH-BOUND are non-negative integers. `list-of??' | + returns a predicate which returns true if its argument is a list | + of length between LOW-BOUND and HIGH-BOUND (inclusive); every | + element of which satisfies PREDICATE. | + | + - Function: list-of?? predicate bound | + BOUND is an integer. If BOUND is negative, `list-of??' returns a | + predicate which returns true if its argument is a list of length | + greater than `(- BOUND)'; every element of which satisfies | + PREDICATE. Otherwise, `list-of??' returns a predicate which | + returns true if its argument is a list of length less than or | + equal to BOUND; every element of which satisfies PREDICATE. | + | + - 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)) + => (5 4 3 2) | + + (remove 'foo '(bar baz bang)) + => (bang baz bar) | + + - 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)) + => (7 5 3 1) | + + - 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)) + => (7 5 3 1) | + + - 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 + + The procedure `remove-duplicates' uses `member' (rather than `memv'). + + - Function: remove-duplicates lst + returns a copy of LST with its duplicate members removed. + Elements are considered duplicate if they are `equal?'. + + Example: + (remove-duplicates '(1 2 3 4)) + => (4 3 2 1) + + (remove-duplicates '(2 4 3 4)) + => (3 4 2) + + +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: 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 + + - Function: butlast lst n + `butlast' returns all but the last N elements of LST. + + Example: + (butlast '(a b c d) 3) + => (a) + (butlast '(a b c d) 4) + => () + +`last' and `butlast' split a list into two parts when given identical +arugments. + (last '(a b c d e) 2) + => (d e) + (butlast '(a b c d e) 2) + => (a b c) + + - Function: nthcdr n lst + `nthcdr' takes N `cdr's of LST and returns the result. Thus + `(nthcdr 3 LST)' == `(cdddr LST)' + + Example: + (nthcdr 2 '(a b c d)) + => (c d) + (nthcdr 0 '(a b c d)) + => (a b c d) + + - Function: butnthcdr n lst + `butnthcdr' returns all but the nthcdr N elements of LST. + + Example: + (butnthcdr 3 '(a b c d)) + => (a b c) + (butnthcdr 4 '(a b c d)) + => (a b c d) | + +`nthcdr' and `butnthcdr' split a list into two parts when given +identical arugments. + (nthcdr 2 '(a b c d e)) + => (c d e) + (butnthcdr 2 '(a b c d e)) + => (a b) + + +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 + | + +File: slib.info, Node: Tree Operations, Next: Type Coercion, Prev: Common List Functions, 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: Type Coercion, Next: Chapter Ordering, Prev: Tree Operations, Up: Procedures + | +Type Coercion | +------------- | + | + `(require 'coerce)' | + | + - Function: type-of obj | + Returns a symbol name for the type of OBJ. | + | + - Function: coerce obj result-type | + Converts and returns OBJ of type `char', `number', `string', | + `symbol', `list', or `vector' to RESULT-TYPE (which must be one of | + these symbols). | + | + +File: slib.info, Node: Chapter Ordering, Next: Sorting, Prev: Type Coercion, Up: Procedures + | +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: Sorting, Next: Topological Sort, Prev: Chapter Ordering, 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: String-Case, 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: String-Case, Next: String Ports, Prev: Topological Sort, 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. + + - Function: string-ci->symbol str + Converts string STR to a symbol having the same case as if the + symbol had been `read'. + + - Function: symbol-append obj1 ... | + Converts OBJ1 ... to strings, appends them, and converts to a | + symbol which is returned. Strings and numbers are converted to | + read's symbol case; the case of symbol characters is not changed. | + #f is converted to the empty string (symbol). | + | + +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: Line I/O, Prev: String Ports, Up: Procedures + +String Search +------------- + + `(require 'string-search)' + + - Procedure: string-index string char + - Procedure: string-index-ci 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: string-reverse-index string char + - Procedure: string-reverse-index-ci string char + Returns the index of the last occurence of CHAR within STRING, or + `#f' if the STRING does not contain a character CHAR. + + - procedure: substring? pattern string + - procedure: substring-ci? 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 + Looks for a string STR within the first MAX-NO-CHARS chars of the + input port IN-PORT. + + - Procedure: find-string-from-port? str in-port + When called with two arguments, the search span is limited by the + end of the input stream. + + - Procedure: find-string-from-port? str in-port char + Searches up to the first occurrence of character CHAR in STR. + + - Procedure: find-string-from-port? str in-port proc + Searches up to the first occurrence of the procedure PROC + returning non-false when called with a character (from IN-PORT) + argument. + + When the STR is found, `find-string-from-port?' 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. + + - Function: string-subst txt old1 new1 ... + Returns a copy of string TXT with all occurrences of string OLD1 + in TXT replaced with NEW1, OLD2 replaced with NEW2 .... + + +File: slib.info, Node: Line I/O, Next: Multi-Processing, Prev: String Search, 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. The PORT argument 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. The PORT argument 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. The PORT argument may be omitted, in which + case it defaults to the value returned by `current-input-port'. + + - Function: display-file path + - Function: display-file path port + Displays the contents of the file named by PATH to PORT. The PORT + argument may be ommited, in which case it defaults to the value + returned by `current-output-port'. + + +File: slib.info, Node: Multi-Processing, Next: Metric Units, Prev: Line I/O, Up: Procedures + | +Multi-Processing +---------------- + + `(require 'process)' + + This module implements asynchronous (non-polled) time-sliced +multi-processing in the SCM Scheme implementation using procedures +`alarm' and `alarm-interrupt'. Until this is ported to another +implementation, consider it an example of writing schedulers in Scheme. + + - 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: Metric Units, Prev: Multi-Processing, Up: Procedures + | +Metric Units | +------------ | + | + `(require 'metric-units)' | + | + <http://swissnet.ai.mit.edu/~jaffer/MIXF.html> | + | + "Metric Interchange Format" is a character string encoding for | +numerical values and units which: | + | + * is unambiguous in all locales; | + | + * uses only [TOG] "Portable Character Set" characters matching "Basic | + Latin" characters in Plane 0 of the Universal Character Set [UCS]; | + | + * is transparent to [UTF-7] and [UTF-8] UCS transformation formats; | + | + * is human readable and writable; | + | + * is machine readable and writable; | + | + * incorporates SI prefixes and units; | + | + * incorporates [ISO 6093] numbers; and | + | + * incorporates [IEC 60027-2] binary prefixes. | + | + In the expression for the value of a quantity, the unit symbol is | +placed after the numerical value. A dot (PERIOD, `.') is placed between | +the numerical value and the unit symbol. | + | + Within a compound unit, each of the base and derived symbols can | +optionally have an attached SI prefix. | + | + Unit symbols formed from other unit symbols by multiplication are | +indicated by means of a dot (PERIOD, `.') placed between them. | + | + Unit symbols formed from other unit symbols by division are indicated | +by means of a SOLIDUS (`/') or negative exponents. The SOLIDUS must | +not be repeated in the same compound unit unless contained within a | +parenthesized subexpression. | + | + The grouping formed by a prefix symbol attached to a unit symbol | +constitutes a new inseparable symbol (forming a multiple or submultiple | +of the unit concerned) which can be raised to a positive or negative | +power and which can be combined with other unit symbols to form compound | +unit symbols. | + | + The grouping formed by surrounding compound unit symbols with | +parentheses (`(' and `)') constitutes a new inseparable symbol which | +can be raised to a positive or negative power and which can be combined | +with other unit symbols to form compound unit symbols. | + | + Compound prefix symbols, that is, prefix symbols formed by the | +juxtaposition of two or more prefix symbols, are not permitted. | + | + Prefix symbols are not used with the time-related unit symbols min | +(minute), h (hour), d (day). No prefix symbol may be used with dB | +(decibel). Only submultiple prefix symbols may be used with the unit | +symbols L (liter), Np (neper), o (degree), oC (degree Celsius), rad | +(radian), and sr (steradian). Submultiple prefix symbols may not be | +used with the unit symbols t (metric ton), r (revolution), or Bd (baud). | + | + A unit exponent follows the unit, separated by a CIRCUMFLEX (`^'). | +Exponents may be positive or negative. Fractional exponents must be | +parenthesized. | + | +SI Prefixes | +........... | + | + Factor Name Symbol | Factor Name Symbol | + ====== ==== ====== | ====== ==== ====== | + 1e24 yotta Y | 1e-1 deci d | + 1e21 zetta Z | 1e-2 centi c | + 1e18 exa E | 1e-3 milli m | + 1e15 peta P | 1e-6 micro u | + 1e12 tera T | 1e-9 nano n | + 1e9 giga G | 1e-12 pico p | + 1e6 mega M | 1e-15 femto f | + 1e3 kilo k | 1e-18 atto a | + 1e2 hecto h | 1e-21 zepto z | + 1e1 deka da | 1e-24 yocto y | + | +Binary Prefixes | +............... | + | + These binary prefixes are valid only with the units B (byte) and bit. | +However, decimal prefixes can also be used with bit; and decimal | +multiple (not submultiple) prefixes can also be used with B (byte). | + | + Factor (power-of-2) Name Symbol | + ====== ============ ==== ====== | + 1.152921504606846976e18 (2^60) exbi Ei | + 1.125899906842624e15 (2^50) pebi Pi | + 1.099511627776e12 (2^40) tebi Ti | + 1.073741824e9 (2^30) gibi Gi | + 1.048576e6 (2^20) mebi Mi | + 1.024e3 (2^10) kibi Ki | + | +Unit Symbols | +............ | + | + Type of Quantity Name Symbol Equivalent | + ================ ==== ====== ========== | + time second s | + time minute min = 60.s | + time hour h = 60.min | + time day d = 24.h | + frequency hertz Hz s^-1 | + signaling rate baud Bd s^-1 | + length meter m | + volume liter L dm^3 | + plane angle radian rad | + solid angle steradian sr rad^2 | + plane angle revolution * r = 6.283185307179586.rad | + plane angle degree * o = 2.777777777777778e-3.r | + information capacity bit bit | + information capacity byte, octet B = 8.bit | + mass gram g | + mass ton t Mg | + mass unified atomic mass unit u = 1.66053873e-27.kg | + amount of substance mole mol | + catalytic activity katal kat mol/s | + thermodynamic temperature kelvin K | + centigrade temperature degree Celsius oC | + luminous intensity candela cd | + luminous flux lumen lm cd.sr | + illuminance lux lx lm/m^2 | + force newton N m.kg.s^-2 | + pressure, stress pascal Pa N/m^2 | + energy, work, heat joule J N.m | + energy electronvolt eV = 1.602176462e-19.J | + power, radiant flux watt W J/s | + logarithm of power ratio neper Np | + logarithm of power ratio decibel * dB = 0.1151293.Np | + electric current ampere A | + electric charge coulomb C s.A | + electric potential, EMF volt V W/A | + capacitance farad F C/V | + electric resistance ohm Ohm V/A | + electric conductance siemens S A/V | + magnetic flux weber Wb V.s | + magnetic flux density tesla T Wb/m^2 | + inductance henry H Wb/A | + radionuclide activity becquerel Bq s^-1 | + absorbed dose energy gray Gy m^2.s^-2 | + dose equivalent sievert Sv m^2.s^-2 | + | + * The formulas are: | + | + * r/rad = 8 * atan(1) | + | + * o/r = 1 / 360 | + | + * db/Np = ln(10) / 20 | + | + - Function: si:conversion-factor to-unit from-unit | + If the strings FROM-UNIT and TO-UNIT express valid unit | + expressions for quantities of the same unit-dimensions, then the | + value returned by `si:conversion-factor' will be such that | + multiplying a numerical value expressed in FROM-UNITs by the | + returned conversion factor yields the numerical value expressed in | + TO-UNITs. | + | + Otherwise, `si:conversion-factor' returns: | + | + -3 | + if neither FROM-UNIT nor TO-UNIT is a syntactically valid | + unit. | + | + -2 | + if FROM-UNIT is not a syntactically valid unit. | + | + -1 | + if TO-UNIT is not a syntactically valid unit. | + | + 0 | + if linear conversion (by a factor) is not possible. | + | + | + (si:conversion-factor "km/s" "m/s" ) => 0.001 | + (si:conversion-factor "N" "m/s" ) => 0 | + (si:conversion-factor "moC" "oC" ) => 1000 | + (si:conversion-factor "mK" "oC" ) => 0 | + (si:conversion-factor "rad" "o" ) => 0.0174533 | + (si:conversion-factor "K" "o" ) => 0 | + (si:conversion-factor "K" "K" ) => 1 | + (si:conversion-factor "oK" "oK" ) => -3 | + (si:conversion-factor "" "s/s" ) => 1 | + (si:conversion-factor "km/h" "mph" ) => -2 | + | + +File: slib.info, Node: Standards Support, Next: Session Support, Prev: Procedures, Up: Other Packages + | +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 +* Eval:: 'eval +* Values:: 'values + + +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. Thanks to Alan +Bawden for contributing this algorithm. + + - Function: rationalize x y + 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. + + `Rationalize' has limited use in implementations lacking exact +(non-integer) rational numbers. The following procedures return a list +of the numerator and denominator. + + - Function: find-ratio x y + `find-ratio' returns the list of the _simplest_ numerator and + denominator whose quotient differs from X by no more than Y. + + (find-ratio 3/97 .0001) => (3 97) | + (find-ratio 3/97 .001) => (1 32) | + + - Function: find-ratio-between x y + `find-ratio-between' returns the list of the _simplest_ numerator + and denominator between X and Y. + + (find-ratio-between 2/7 3/5) => (1 2) | + (find-ratio-between -3/5 -2/7) => (-1 2) | + + +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: Eval, 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: Eval, Next: Values, Prev: Dynamic-Wind, Up: Standards Support + +Eval +---- + + `(require 'eval)' + + - Function: eval expression environment-specifier + Evaluates EXPRESSION in the specified environment and returns its + value. EXPRESSION must be a valid Scheme expression represented + as data, and ENVIRONMENT-SPECIFIER must be a value returned by one + of the three procedures described below. Implementations may + extend `eval' to allow non-expression programs (definitions) as + the first argument and to allow other values as environments, with + the restriction that `eval' is not allowed to create new bindings + in the environments associated with `null-environment' or + `scheme-report-environment'. + + (eval '(* 7 3) (scheme-report-environment 5)) + => 21 + + (let ((f (eval '(lambda (f x) (f x x)) + (null-environment)))) + (f + 10)) + => 20 + + - Function: scheme-report-environment version + - Function: null-environment version + - Function: null-environment + VERSION must be an exact non-negative integer N corresponding to a + version of one of the Revised^N Reports on Scheme. + `Scheme-report-environment' returns a specifier for an environment + that contains the set of bindings specified in the corresponding + report that the implementation supports. `Null-environment' + returns a specifier for an environment that contains only the + (syntactic) bindings for all the syntactic keywords defined in the + given version of the report. + + Not all versions may be available in all implementations at all + times. However, an implementation that conforms to version N of + the Revised^N Reports on Scheme must accept version N. An error + is signalled if the specified version is not available. + + The effect of assigning (through the use of `eval') a variable + bound in a `scheme-report-environment' (for example `car') is + unspecified. Thus the environments specified by + `scheme-report-environment' may be immutable. + + + - Function: interaction-environment + This optional procedure returns a specifier for the environment + that contains implementation-defined bindings, typically a + superset of those listed in the report. The intent is that this + procedure will return the environment in which the implementation + would evaluate expressions dynamically typed by the user. + +Here are some more `eval' examples: + + (require 'eval) + => #<unspecified> + (define car 'volvo) + => #<unspecified> + car + => volvo + (eval 'car (interaction-environment)) + => volvo + (eval 'car (scheme-report-environment 5)) + => #<primitive-procedure car> + (eval '(eval 'car (interaction-environment)) + (scheme-report-environment 5)) + => volvo + (eval '(eval '(set! car 'buick) (interaction-environment)) + (scheme-report-environment 5)) + => #<unspecified> + car + => buick + (eval 'car (scheme-report-environment 5)) + => #<primitive-procedure car> + (eval '(eval 'car (interaction-environment)) + (scheme-report-environment 5)) + => buick + + +File: slib.info, Node: Values, Prev: Eval, 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: Session Support, Next: Extra-SLIB Packages, Prev: Standards Support, Up: Other Packages + +Session Support +=============== + +* Menu: + +* Repl:: Macros at top-level +* Quick Print:: Loop-safe Output +* Debug:: To err is human ... +* Breakpoints:: Pause execution +* Trace:: 'trace +* System Interface:: 'system, 'getenv, and 'net-clients + + +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' .... + + - Procedure: track-all file ... + Tracks (*note Trace::) all procedures `define'd at top-level in + `file' .... + + - Procedure: stack-all file ... + Stacks (*note Trace::) all procedures `define'd at top-level in + `file' .... + + - Procedure: break-all file ... + Breakpoints (*note Breakpoints::) all procedures `define'd at + top-level in `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. + + These are _procedures_ for breaking. If defmacros are not natively +supported by your implementation, these might be more convenient to use. + + - Function: breakf proc + - Function: 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 + To unbreak, type + (set! SYMBOL (unbreakf SYMBOL)) + + +File: slib.info, Node: Trace, Next: System Interface, Prev: Breakpoints, Up: Session Support + +Tracing +------- + + `(require 'trace)' + +This feature provides three ways to monitor procedure invocations: + +stack + Pushes the procedure-name when the procedure is called; pops when + it returns. + +track + Pushes the procedure-name and arguments when the procedure is + called; pops when it returns. + +trace + Pushes the procedure-name and prints `CALL PROCEDURE-NAME ARG1 + ...' when the procdure is called; pops and prints `RETN + PROCEDURE-NAME VALUE' when the procedure returns. + + - Variable: debug:max-count + If a traced procedure calls itself or untraced procedures which + call it, stack, track, and trace will limit the number of stack + pushes to DEBUG:MAX-COUNT. + + - Function: print-call-stack + - Function: print-call-stack port + Prints the call-stack to PORT or the current-error-port. + + - 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: track proc1 ... + Traces the top-level named procedures given as arguments. + + - Macro: track + With no arguments, makes sure that all the currently tracked + identifiers are tracked (even if those identifiers have been + redefined) and returns a list of the tracked identifiers. + + - Macro: stack proc1 ... + Traces the top-level named procedures given as arguments. + + - Macro: stack + With no arguments, makes sure that all the currently stacked + identifiers are stacked (even if those identifiers have been + redefined) and returns a list of the stacked identifiers. + + - Macro: untrace proc1 ... + Turns tracing, tracking, and off for its arguments. + + - Macro: untrace + With no arguments, untraces all currently traced identifiers and + returns a list of these formerly traced identifiers. + + - Macro: untrack proc1 ... + Turns tracing, tracking, and off for its arguments. + + - Macro: untrack + With no arguments, untracks all currently tracked identifiers and + returns a list of these formerly tracked identifiers. + + - Macro: unstack proc1 ... + Turns tracing, stacking, and off for its arguments. + + - Macro: unstack + With no arguments, unstacks all currently stacked identifiers and + returns a list of these formerly stacked identifiers. + + These are _procedures_ for tracing. If defmacros are not natively +supported by your implementation, these might be more convenient to use. + + - Function: tracef proc + - Function: 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 + Removes tracing, tracking, or stacking for PROC. To untrace, type + (set! SYMBOL (untracef SYMBOL)) + + +File: slib.info, Node: System Interface, Prev: Trace, 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. + +If `system' is provided by the Scheme implementation, the "net-clients" +package provides interfaces to common network client programs like FTP, +mail, and Netscape. + + `(require 'net-clients)' + + - Function: call-with-tmpnam proc + - Function: call-with-tmpnam proc k + Calls PROC with K arguments, strings returned by successive calls + to `tmpnam'. If PROC returns, then any files named by the + arguments to PROC are deleted automatically and the value(s) + yielded by the PROC is(are) returned. K may be ommited, in which + case it defaults to `1'. + + - Function: user-email-address + `user-email-address' returns a string of the form + `username@hostname'. If this e-mail address cannot be obtained, + #f is returned. + + - Function: current-directory + `current-directory' returns a string containing the absolute file + name representing the current working directory. If this string + cannot be obtained, #f is returned. + + If `current-directory' cannot be supported by the platform, the + value of `current-directory' is #f. + + - Function: make-directory name + Creates a sub-directory NAME of the current-directory. If + successful, `make-directory' returns #t; otherwise #f. + + - Function: null-directory? file-name + Returns #t if changing directory to FILE-NAME makes the current + working directory the same as it is before changing directory; + otherwise returns #f. + + - Function: absolute-path? file-name + Returns #t if FILE-NAME is a fully specified pathname (does not + depend on the current working directory); otherwise returns #f. + + - Function: glob-pattern? str + Returns #t if the string STR contains characters used for + specifying glob patterns, namely `*', `?', or `['. + + - Function: parse-ftp-address uri | + Returns a list of the decoded FTP URI; or #f if indecipherable. | + FTP "Uniform Resource Locator", "ange-ftp", and "getit" formats + are handled. The returned list has four elements which are + strings or #f: + + 0. username + + 1. password + + 2. remote-site + + 3. remote-directory + + - Function: ftp-upload paths user password remote-site remote-dir + PASSWORD must be a non-empty string or #f. PATHS must be a + non-empty list of pathnames or Glob patterns (*note Filenames::) + matching files to transfer. + + `ftp-upload' puts the files specified by PATHS into the REMOTE-DIR + directory of FTP REMOTE-SITE using name USER with (optional) + PASSWORD. + + If PASSWORD is #f and USER is not `ftp' or `anonymous', then USER + is ignored; FTP takes the username and password from the `.netrc' + or equivalent file. + + - Function: path->uri path | + Returns a URI-string for PATH on the local host. | + + - Function: browse-url-netscape url + If a `netscape' browser is running, `browse-url-netscape' causes + the browser to display the page specified by string URL and + returns #t. + + If the browser is not running, `browse-url-netscape' runs + `netscape' with the argument URL. If the browser starts as a + background job, `browse-url-netscape' returns #t immediately; if + the browser starts as a foreground job, then `browse-url-netscape' + returns #t when the browser exits; otherwise it returns #f. + + +File: slib.info, Node: Extra-SLIB Packages, Prev: Session Support, Up: Other Packages + +Extra-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). + + http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz + + swissnet.ai.mit.edu:/pub/scm/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 + + +SCHELOG + is an embedding of Prolog in Scheme. + http://www.cs.rice.edu/CS/PLT/packages/schelog/ + + +JFILTER + is a Scheme program which converts text among the JIS, EUC, and + Shift-JIS Japanese character sets. + http://www.sci.toyama-u.ac.jp/~iwao/Scheme/Jfilter/index.html + + +File: slib.info, Node: About SLIB, Next: Index, Prev: Other Packages, Up: Top + +About SLIB +********** + +More people than I can name have contributed to SLIB. Thanks to all of +you! + + SLIB 2d1, released March 2001. | + Aubrey Jaffer <jaffer @ ai.mit.edu> + Hyperactive Software - The Maniac Inside! + <http://swissnet.ai.mit.edu/~jaffer/SLIB.html> + +* Menu: + +* Installation:: How to install SLIB on your system. +* Porting:: SLIB to new platforms. +* Coding Guidelines:: How to write modules for SLIB. +* Copyrights:: Intellectual propery issues. + + +File: slib.info, Node: Installation, Next: Porting, Prev: About SLIB, Up: About SLIB + +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'. Scheme48 +supports `getenv' but does not use it for determining +`library-vicinity'. (That is done from the Makefile.) + + 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. + + - Implementation: SCM + The SCM implementation does not require any initialization file as + SLIB support is already built into SCM. See the documentation + with SCM for installation instructions. + + - Implementation: VSCM + 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. + + 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")' + + 4. 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.) + + + - Implementation: Scheme48 + To make a Scheme48 image for an installation under `<prefix>', + + 1. `cd' to the SLIB directory + + 2. type `make prefix=<prefix> slib48'. + + 3. To install the image, type `make prefix=<prefix> install48'. + This will also create a shell script with the name `slib48' + which will invoke the saved image. + + - Implementation: PLT Scheme + - Implementation: DrScheme + - Implementation: MzScheme + Date: Mon, 2 Oct 2000 21:29:48 -0400 (EDT) + From: Shriram Krishnamurthi <sk@cs.brown.edu> + + We distribute an SLIB init file for our system. If you have PLT + Scheme (our preferred name for the entire suite, which includes + DrScheme, MzScheme and other implementations) installed, you ought + to be able to run "help-desk", or run `drscheme' and choose Help + Desk from the Help menu; in Help Desk, type `slib'. This will give + instructions for how to load the SLIB init file. + + +File: slib.info, Node: Porting, Next: Coding Guidelines, Prev: Installation, Up: About SLIB + +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', `Revised^4 Report on the +Algorithmic Language Scheme', or `Revised^5 Report on the Algorithmic +Language Scheme' in order to support SLIB. (1) + + `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 (these functions are +documented in the section *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. + + ---------- Footnotes ---------- + + (1) If you are porting a `Revised^3 Report on the Algorithmic +Language Scheme' implementation, then you will need to finish writing +`sc4sc3.scm' and `load' it from your initialization file. + + +File: slib.info, Node: Coding Guidelines, Next: Copyrights, Prev: Porting, Up: About SLIB + +Coding Guidelines +================= + + 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::). + + 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)'. + + Code submitted for inclusion in SLIB should not duplicate routines +already in SLIB files. Use `require' to force those library routines +to be used by 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, Prev: Coding Guidelines, Up: About SLIB + +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: Index, Prev: About SLIB, 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. +* absolute-path?: System Interface. +* add-domain: Database Utilities. +* add-process!: Multi-Processing. +* add-setter: Setters. +* adjoin: Lists as sets. +* adjoin-parameters!: Parameter lists. +* alarm: Multi-Processing. +* alarm-interrupt: Multi-Processing. +* 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-index-map!: Array Mapping. +* array-indexes: Array Mapping. +* array-map!: Array Mapping. +* array-rank: Arrays. +* array-ref: Arrays. +* array-set!: Arrays. +* array-shape: Arrays. +* array?: Arrays. +* asctime: Posix Time. +* ash: Bit-Twiddling. +* atom?: Non-List functions. +* batch:call-with-output-script: Batch. +* batch:command: Batch. +* batch:comment: Batch. +* batch:delete-file: Batch. +* batch:initialize!: Batch. +* batch:lines->file: Batch. +* batch:rename-file: Batch. +* batch:run-script: Batch. +* batch:try-chopped-command: Batch. +* batch:try-command: Batch. +* bit-extract: Bit-Twiddling. +* bit-field: Bit-Twiddling. +* bitwise-if: Bit-Twiddling. +* break: Breakpoints. +* break-all: Debug. +* breakf: Breakpoints. +* breakpoint: Breakpoints. +* browse: Database Browser. +* browse-url-netscape: System Interface. +* butlast: Lists as sequences. +* butnthcdr: Lists as sequences. +* byte-ref: Byte. +* byte-set!: Byte. +* bytes: Byte. +* bytes->list: Byte. +* bytes-length: Byte. +* call-with-dynamic-binding: Dynamic Data Type. +* call-with-input-string: String Ports. +* call-with-output-string: String Ports. +* call-with-tmpnam: System Interface. +* call-with-values: Values. +* capture-syntactic-environment: Syntactic Closures. +* cart-prod-tables: Relational Database Operations. +* catalog->html: HTML Tables. | +* cgi:serve-query: HTTP and CGI. +* 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: Type Coercion. | +* collection?: Collections. +* combined-rulesets: Commutative Rings. +* command->p-specs: HTML. | +* command:make-editable-table: HTML Tables. | +* command:modify-table: HTML Tables. | +* continue: Breakpoints. +* copy-bit: Bit-Twiddling. +* copy-bit-field: Bit-Twiddling. +* copy-list: List construction. +* copy-random-state: Random Numbers. +* copy-tree: Tree Operations. +* create-database <1>: Database Utilities. +* create-database: Creating and Opening Relational Databases. +* create-report: Database Reports. +* create-table: Relational Database Operations. +* create-view: Relational Database Operations. +* cring:define-rule: Commutative Rings. +* ctime: Posix Time. +* current-directory: System Interface. +* current-error-port: Input/Output. +* current-input-port <1>: Byte. +* current-input-port: Ruleset Definition and Use. +* current-output-port: Byte. +* current-time: Time and Date. +* db->html-directory: HTML Tables. | +* db->html-files: HTML Tables. | +* db->netscape: HTML Tables. +* decode-universal-time: Common-Lisp Time. +* 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*: 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. +* determinant: Determinant. | +* difftime: Time and Date. +* display-file: Line I/O. +* 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: Common-Lisp Time. +* enquque!: Queues. +* equal?: Byte. +* eval: Eval. +* every: Lists as sets. +* every?: Collections. +* extended-euclid: Modular Arithmetic. +* factor: Prime Numbers. +* fft: Fast Fourier Transform. +* fft-1: Fast Fourier Transform. +* file-exists?: Input/Output. +* filename:match-ci??: Filenames. +* filename:match??: Filenames. +* filename:substitute-ci??: Filenames. +* filename:substitute??: Filenames. +* fill-empty-parameters: Parameter lists. +* find-if: Lists as sets. +* find-ratio: Rationalize. +* find-ratio-between: Rationalize. +* find-string-from-port?: String Search. +* fluid-let: Fluid-Let. +* for-each-elt: Collections. +* for-each-key <1>: Collections. +* for-each-key: Base Table. +* for-each-row: Table Operations. +* force-output: Input/Output. +* form:delimited: HTML. | +* form:element: HTML. | +* form:image: HTML. | +* form:reset: HTML. | +* form:submit: HTML. | +* format: Format Interface. +* fprintf: Standard Formatted Output. +* fscanf: Standard Formatted Input. +* ftp-upload: System Interface. +* generic-write: Generic-Write. +* gentemp: Defmacro. +* get: Table Operations. +* get*: Table Operations. +* get-decoded-time: Common-Lisp Time. +* get-method: Object. +* get-universal-time: Common-Lisp Time. +* getenv: System Interface. +* getopt: Getopt. +* getopt--: Getopt. +* getopt->arglist: Getopt Parameter lists. +* getopt->parameter-list: Getopt Parameter lists. +* glob-pattern?: System Interface. +* gmktime: Posix Time. +* gmtime: Posix Time. +* golden-section-search: Minimizing. +* gtime: Posix 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. +* home-vicinity: Vicinity. +* html:anchor: URI. | +* html:atval: HTML. +* html:base: URI. | +* html:body: HTML. +* html:buttons: HTML. | +* html:caption: HTML Tables. | +* html:checkbox: HTML. | +* html:comment: HTML. +* html:editable-row-converter: HTML Tables. | +* html:form: HTML. +* html:head: HTML. +* html:heading: HTML Tables. +* html:hidden: HTML. | +* html:href-heading: HTML Tables. +* html:http-equiv: HTML. | +* html:isindex: URI. | +* html:link: URI. | +* html:linked-row-converter: HTML Tables. | +* html:meta: HTML. | +* html:meta-refresh: HTML. | +* html:plain: HTML. +* html:pre: HTML. +* html:select: HTML. | +* html:table: HTML Tables. +* html:text: HTML. | +* html:text-area: HTML. | +* http:content: HTTP and CGI. +* http:error-page: HTTP and CGI. +* http:forwarding-page: HTTP and CGI. | +* http:header: HTTP and CGI. +* http:serve-query: HTTP and CGI. +* 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. +* interaction-environment: Eval. +* intersection: Lists as sets. +* jacobi-symbol: Prime Numbers. +* 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->bytes: Byte. +* list->string: Rev4 Optional Procedures. +* list->vector: Rev4 Optional Procedures. +* list-of??: Lists as sets. | +* list-table-definition: Database Utilities. | +* list-tail: Rev4 Optional Procedures. +* load-option: Weight-Balanced Trees. +* localtime: Posix 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-bytes: Byte. +* make-command-server: Database Utilities. +* make-directory: System Interface. +* 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-query-alist-command-server: HTTP and CGI. | +* make-queue: Queues. +* make-random-state: Random Numbers. +* make-record-type: Records. +* make-relational-system: Creating and Opening Relational Databases. +* make-ruleset: Commutative Rings. +* make-shared-array: Arrays. +* make-sierpinski-indexer: Hashing. +* make-syntactic-closure: Syntactic Closures. +* make-table: Base Table. +* make-uri: URI. | +* 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: Posix 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. +* null-directory?: System Interface. +* null-environment: Eval. +* object: Yasos interface. +* object->limited-string: Object-To-String. +* object->string: Object-To-String. +* object-with-ancestors: Yasos interface. +* object?: Object. +* offset-time: Time and Date. +* 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. +* parse-ftp-address: System Interface. +* path->uri: System Interface. | +* plot!: Plotting. +* plot-function!: Plotting. +* pnm:array-write: Portable Image Files. +* pnm:image-file->array: Portable Image Files. +* pnm:type-dimensions: Portable Image Files. +* position: Lists as sequences. +* pprint-file: Pretty-Print. +* pprint-filter-file: Pretty-Print. +* prec:commentfix: Grammar Rule Definition. +* prec:define-grammar: Ruleset Definition and Use. +* prec:delim: Grammar Rule Definition. +* prec:infix: Grammar Rule Definition. +* prec:inmatchfix: Grammar Rule Definition. +* prec:make-led: Nud and Led Definition. +* prec:make-nud: Nud and Led Definition. +* prec:matchfix: Grammar Rule Definition. +* prec:nary: Grammar Rule Definition. +* prec:nofix: Grammar Rule Definition. +* prec:parse: Ruleset Definition and Use. +* prec:postfix: Grammar Rule Definition. +* prec:prefix: Grammar Rule Definition. +* prec:prestfix: Grammar Rule Definition. +* predicate->asso: Association Lists. +* predicate->hash: Hash Tables. +* predicate->hash-asso: Hash Tables. +* present?: Base Table. +* pretty-print: Pretty-Print. +* pretty-print->string: Pretty-Print. | +* prime?: Prime Numbers. +* primes<: Prime Numbers. +* primes>: Prime Numbers. +* print: Yasos interface. +* print-call-stack: Trace. +* printf: Standard Formatted Output. +* process:schedule!: Multi-Processing. +* program-vicinity: Vicinity. +* project-table: Relational Database Operations. +* provide <1>: Require. +* provide: Feature. +* provided? <1>: Require. +* provided?: Feature. +* 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-byte: Byte. +* read-command: Command Line. +* read-line: Line I/O. +* read-line!: Line I/O. +* read-options-file: Command Line. +* record-accessor: Records. +* record-constructor: Records. +* record-modifier: Records. +* record-predicate: Records. +* reduce <1>: Lists as sequences. +* reduce: Collections. +* reduce-init: Lists as sequences. +* remove: Lists as sets. +* remove-duplicates: Lists as sets. +* remove-if: Lists as sets. +* remove-if-not: Lists as sets. +* remove-parameter: Parameter lists. +* remove-setter-for: Setters. +* repl:quit: Repl. +* repl:top-level: Repl. +* replace-suffix: Filenames. +* require <1>: Require. +* require <2>: Catalog Compilation. +* require: Requesting Features. +* require:feature->path <1>: Require. +* require:feature->path: Requesting Features. +* 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. +* scheme-report-environment: Eval. +* schmooz: Schmooz. +* secant:find-bracketed-root: Root Finding. +* secant:find-root: Root Finding. +* seed->random-state: Random Numbers. +* set: Setters. +* set-: Structures. +* set-difference: Lists as sets. +* Setter: Collections. +* setter: Setters. +* si:conversion-factor: Metric Units. | +* singleton-wt-tree: Construction of Weight-Balanced Trees. +* size <1>: Collections. +* size: Yasos interface. +* 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. +* slib:warn: System. +* software-type: Configuration. +* some: Lists as sets. +* sort: Sorting. +* sort!: Sorting. +* sorted?: Sorting. +* soundex: Hashing. +* sprintf: Standard Formatted Output. +* sscanf: Standard Formatted Input. +* stack: Trace. +* stack-all: Debug. +* string->list: Rev4 Optional Procedures. +* string-capitalize: String-Case. +* string-captialize!: String-Case. +* string-ci->symbol: 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-index-ci: String Search. +* string-join: Batch. +* string-null?: Rev2 Procedures. +* string-reverse-index: String Search. +* string-reverse-index-ci: String Search. +* string-subst: String Search. +* string-upcase: String-Case. +* string-upcase!: String-Case. +* sub-vicinity: Vicinity. +* subst: Tree Operations. +* substq: Tree Operations. +* substring-ci?: String Search. +* 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. +* symbol-append: String-Case. | +* symmetric:modulus: Modular Arithmetic. +* sync-base: Base Table. +* sync-database: Relational Database Operations. | +* 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->linked-html: HTML Tables. | +* table->linked-page: HTML Tables. | +* table-exists?: Relational Database Operations. +* table-name->filename: HTML Tables. +* TAG: Structures. +* 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. +* time-zone: Time Zone. +* tmpnam: Input/Output. +* tok:char-group: Token definition. +* topological-sort: Topological Sort. +* trace: Trace. +* trace-all: Debug. +* tracef: Trace. +* track: Trace. +* track-all: Debug. +* transcript-off: Transcripts. +* transcript-on: Transcripts. +* transformer: Syntactic Closures. +* truncate-up-to: Batch. +* tsort: Topological Sort. +* two-arg:-: Multi-argument / and -. +* two-arg:/: Multi-argument / and -. +* two-arg:apply: Multi-argument Apply. +* type-of: Type Coercion. | +* tz:params: Time Zone. +* tzset: Time Zone. +* unbreak: Breakpoints. +* unbreakf: Breakpoints. +* union: Lists as sets. +* unmake-method!: Object. +* unstack: Trace. +* untrace: Trace. +* untracef: Trace. +* untrack: Trace. +* uri->tree: URI. | +* uric:decode: URI. | +* uric:encode: URI. | +* user-email-address: System Interface. +* 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-byte: Byte. +* 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. + +Variable Index +************** + + This is an alphabetical list of all the global variables in SLIB. + +* Menu: + +* *catalog*: Require. +* *features*: Require. +* *http:byline*: HTTP and CGI. +* *modules*: Require. +* *optarg*: Getopt. +* *optind*: Getopt. +* *qp-width*: Quick Print. +* *random-state*: Random Numbers. +* *ruleset*: Commutative Rings. +* *syn-defs*: Ruleset Definition and Use. +* *syn-ignore-whitespace*: Ruleset Definition and Use. +* *timezone*: Time Zone. +* 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. +* daylight?: Time Zone. +* debug:max-count: Trace. +* distribute*: Commutative Rings. +* distribute/: Commutative Rings. +* most-positive-fixnum: Configuration. +* nil: Legacy. +* number-wt-type: Construction of Weight-Balanced Trees. +* primary-limit: Table Operations. +* prime:prngs: Prime Numbers. +* prime:trials: Prime Numbers. +* 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. +* tok:decimal-digits: Token definition. +* tok:lower-case: Token definition. +* tok:upper-case: Token definition. +* tok:whitespaces: Token definition. +* tzname: Time Zone. + +Concept and Feature Index +************************* + +* Menu: + +* alist: Association Lists. +* alist-table <1>: Creating and Opening Relational Databases. +* alist-table: Base Table. +* ange-ftp: System Interface. +* array: Arrays. +* array-for-each: Array Mapping. +* attribute-value: HTML. +* balanced binary trees: Weight-Balanced Trees. +* base: URI. | +* batch: Batch. +* binary trees: Weight-Balanced Trees. +* binary trees, as discrete maps: Weight-Balanced Trees. +* binary trees, as sets: Weight-Balanced Trees. +* break: Breakpoints. +* byte: Byte. +* calendar time <1>: Posix Time. +* calendar time: Time and Date. +* Calendar-Time: Posix Time. +* caltime: Posix Time. +* careful: Commutative Rings. +* catalog: Requesting Features. +* Catalog File: Library Catalogs. +* chapter-order: Chapter Ordering. +* charplot: Plotting. +* coerce: Type Coercion. | +* collect: Collections. +* command line: Command Line. +* commentfix: Precedence Parsing Overview. +* common-list-functions <1>: Common List Functions. +* common-list-functions: Collections. +* commutative-ring: Commutative Rings. +* Coordinated Universal Time: Posix Time. +* database-utilities <1>: Database Utilities. +* database-utilities: Batch. +* debug <1>: Breakpoints. +* debug: Debug. +* defmacroexpand <1>: Pretty-Print. +* defmacroexpand: Defmacro. +* delim: Precedence Parsing Overview. +* discrete maps, using binary trees: Weight-Balanced Trees. +* DrScheme: Installation. +* dynamic: Dynamic Data Type. +* dynamic-wind: Dynamic-Wind. +* escaped: URI. | +* Euclidean Domain: Commutative Rings. +* factor: Prime Numbers. +* feature <1>: About this manual. +* feature <2>: Requesting Features. +* feature: Feature. +* fft: Fast Fourier Transform. +* fluid-let <1>: Database Utilities. +* fluid-let: Fluid-Let. +* form: HTML. +* format: Format. +* generic-write: Generic-Write. +* getit: System Interface. +* getopt <1>: Database Utilities. +* getopt: Getopt. +* glob <1>: Batch. +* glob: Filenames. +* hash: Hashing. +* hash-table: Hash Tables. +* HOME <1>: Vicinity. +* HOME: Library Catalogs. +* homecat: Catalog Compilation. +* implcat: Catalog Compilation. +* infix: Precedence Parsing Overview. +* inmatchfix: Precedence Parsing Overview. +* Left Denotation, led: Nud and Led Definition. +* line-i: Line I/O. +* logical: Bit-Twiddling. +* macro <1>: Repl. +* macro: R4RS Macros. +* macro-by-example: Macro by Example. +* macros-that-work: Macros That Work. +* make-crc: Cyclic Checksum. +* match: Base Table. +* match-keys <1>: Table Operations. +* match-keys: Base Table. +* matchfix: Precedence Parsing Overview. +* metric-units: Metric Units. | +* minimize: Minimizing. +* minimum field width (printf): Standard Formatted Output. +* mkimpcat.scm: Catalog Compilation. +* mklibcat.scm: Catalog Compilation. +* modular: Modular Arithmetic. +* multiarg-apply: Multi-argument Apply. +* mutliarg: Multi-argument / and -. +* MzScheme: Installation. +* nary: Precedence Parsing Overview. +* net-clients: System Interface. +* new-catalog: Catalog Compilation. | +* nofix: Precedence Parsing Overview. +* null: HTML Tables. | +* Null Denotation, nud: Nud and Led Definition. +* object: Object. +* object->string: Object-To-String. +* oop: Yasos. +* option, run-time-loadable: Weight-Balanced Trees. +* options file: Command Line. +* parameters <1>: Database Utilities. +* parameters <2>: Batch. +* parameters: Parameter lists. +* parse: Precedence Parsing. +* plain-text: HTML. +* PLT Scheme: Installation. +* posix-time: Posix Time. +* postfix: Precedence Parsing Overview. +* pprint-file: Pretty-Print. +* PRE: HTML. +* precedence: Precedence Parsing. +* precision (printf): Standard Formatted Output. +* prefix: Precedence Parsing Overview. +* prestfix: Precedence Parsing Overview. +* pretty-print: Pretty-Print. +* primes: Prime Numbers. +* printf: Standard Formatted Output. +* priority-queue: Priority Queues. +* PRNG: Random Numbers. +* process: Multi-Processing. +* promise: Promises. +* qp <1>: Quick Print. +* qp: Getopt. +* query-string: HTTP and CGI. +* queue: Queues. +* random: Random Numbers. +* rationalize: Rationalize. +* read-command: Command Line. +* record: Records. +* relational-database: Relational Database. +* repl <1>: Repl. +* repl: Syntax-Case Macros. +* reset: HTML. +* rev2-procedures: Rev2 Procedures. +* rev3-report: Coding Guidelines. +* rev4-optional-procedures: Rev4 Optional Procedures. +* ring, commutative: Commutative Rings. +* RNG: Random Numbers. +* root: Root Finding. +* run-time-loadable option: Weight-Balanced Trees. +* scanf: Standard Formatted Input. +* Scheme48: Installation. +* schmooz: Schmooz. +* SCM: Installation. +* Server-based Naming Authority: URI. | +* session: Feature. +* sets, using binary trees: Weight-Balanced Trees. +* sierpinski: Hashing. +* sitecat: Catalog Compilation. +* slibcat: Catalog Compilation. +* sort: Sorting. +* soundex: Hashing. +* stdio: Standard Formatted I/O. +* string-case: String-Case. +* string-port: String Ports. +* string-search: String Search. +* struct: Structures. +* syntactic-closures: Syntactic Closures. +* syntax-case: Syntax-Case Macros. +* time: Time and Date. +* time-zone: Time Zone. +* topological-sort: Topological Sort. +* trace: Trace. +* transcript: Transcripts. +* tree: Tree Operations. +* trees, balanced binary: Weight-Balanced Trees. +* tsort: Topological Sort. +* TZ-string: Time Zone. +* Uniform Resource Identifiers: URI. | +* Uniform Resource Locator: System Interface. +* Unique Factorization: Commutative Rings. +* unsafe: URI. | +* URI: HTTP and CGI. +* usercat: Catalog Compilation. +* UTC: Posix Time. +* values: Values. +* VSCM: Installation. +* weight-balanced binary trees: Weight-Balanced Trees. +* wild-card: Base Table. +* with-file: With-File. +* wt-tree: Weight-Balanced Trees. +* yasos: Yasos. + + + +Tag Table: +Node: Top1026 +Node: The Library System1740 +Node: Feature2054 +Node: Requesting Features3004 +Node: Library Catalogs4363 +Node: Catalog Compilation6815 +Node: Built-in Support9624 +Node: Require10255 +Node: Vicinity12747 +Node: Configuration15714 +Node: Input/Output18655 +Node: Legacy20254 +Node: System21096 +Node: About this manual23588 +Node: Scheme Syntax Extension Packages24145 +Node: Defmacro24830 +Node: R4RS Macros26781 +Node: Macro by Example28036 +Node: Macros That Work30913 +Node: Syntactic Closures36971 +Node: Syntax-Case Macros54405 +Node: Fluid-Let58531 +Node: Yasos59472 +Node: Yasos terms60265 +Node: Yasos interface61289 +Node: Setters63364 +Node: Yasos examples66005 +Node: Textual Conversion Packages68999 +Node: Precedence Parsing69697 +Node: Precedence Parsing Overview70360 +Ref: Precedence Parsing Overview-Footnote-172358 +Node: Ruleset Definition and Use72561 +Node: Token definition74942 +Node: Nud and Led Definition77211 +Node: Grammar Rule Definition79660 +Node: Format87234 +Node: Format Interface87482 +Node: Format Specification89219 +Node: Standard Formatted I/O99349 +Node: Standard Formatted Output99915 +Node: Standard Formatted Input109182 +Node: Programs and Arguments115842 +Node: Getopt116342 +Node: Command Line122184 +Node: Parameter lists125373 +Node: Getopt Parameter lists129358 +Node: Filenames133527 +Node: Batch136757 +Node: HTML144550 +Node: HTML Tables155838 +Node: HTTP and CGI166135 +Node: URI171452 +Node: Printing Scheme177162 +Node: Generic-Write177550 +Node: Object-To-String178953 +Node: Pretty-Print179357 +Node: Time and Date184343 +Node: Time Zone185370 +Node: Posix Time189931 +Node: Common-Lisp Time192067 +Node: Vector Graphics193646 +Node: Tektronix Graphics Support193835 +Node: Schmooz195209 +Node: Mathematical Packages199435 +Node: Bit-Twiddling200069 +Node: Modular Arithmetic204660 +Node: Prime Numbers206794 +Node: Random Numbers208477 +Node: Fast Fourier Transform213113 +Node: Cyclic Checksum214031 +Node: Plotting216292 +Node: Root Finding219151 +Node: Minimizing223138 +Ref: Minimizing-Footnote-1208597 +Node: Commutative Rings225178 +Node: Determinant236562 +Node: Database Packages237120 +Node: Base Table237384 +Node: Relational Database247798 +Node: Motivations248582 +Node: Creating and Opening Relational Databases253629 +Node: Relational Database Operations256061 +Node: Table Operations259258 +Node: Catalog Representation267136 +Node: Unresolved Issues270034 +Node: Database Utilities272985 +Node: Database Reports289598 +Node: Database Browser292352 +Node: Weight-Balanced Trees293413 +Node: Construction of Weight-Balanced Trees297284 +Node: Basic Operations on Weight-Balanced Trees300734 +Node: Advanced Operations on Weight-Balanced Trees303699 +Node: Indexing Operations on Weight-Balanced Trees309721 +Node: Other Packages313635 +Node: Data Structures314034 +Node: Arrays314790 +Node: Array Mapping317744 +Node: Association Lists319661 +Node: Byte321912 +Node: Portable Image Files324152 +Node: Collections325699 +Node: Dynamic Data Type331817 +Node: Hash Tables333078 +Node: Hashing335195 +Node: Object339989 +Node: Priority Queues348225 +Node: Queues349068 +Node: Records350194 +Node: Structures353705 +Node: Procedures355005 +Node: Common List Functions355852 +Node: List construction356276 +Node: Lists as sets357939 +Node: Lists as sequences365060 +Node: Destructive list operations370366 +Node: Non-List functions373029 +Node: Tree Operations374174 +Node: Type Coercion375796 +Node: Chapter Ordering377022 +Node: Sorting378719 +Node: Topological Sort384496 +Node: String-Case386183 +Node: String Ports387284 +Node: String Search388048 +Node: Line I/O390415 +Node: Multi-Processing392065 +Node: Metric Units393248 +Node: Standards Support408689 +Node: With-File409423 +Node: Transcripts409699 +Node: Rev2 Procedures410020 +Node: Rev4 Optional Procedures411727 +Node: Multi-argument / and -412297 +Node: Multi-argument Apply412948 +Node: Rationalize413434 +Node: Promises414876 +Node: Dynamic-Wind415293 +Node: Eval416547 +Node: Values419884 +Node: Session Support420671 +Node: Repl421139 +Node: Quick Print422422 +Node: Debug423535 +Node: Breakpoints424421 +Node: Trace426444 +Node: System Interface429555 +Node: Extra-SLIB Packages433443 +Node: About SLIB435743 +Node: Installation436407 +Node: Porting439635 +Ref: Porting-Footnote-1413781 +Node: Coding Guidelines441153 +Node: Copyrights443234 +Node: Index446519 + +End Tag Table diff --git a/module/slib/slib.spec b/module/slib/slib.spec new file mode 100644 index 000000000..67e1aa530 --- /dev/null +++ b/module/slib/slib.spec @@ -0,0 +1,85 @@ +%define name slib +%define version 2d1 +%define release 1 + +Name: %{name} +Release: %{release} +Version: %{version} +Packager: Radey Shouman <shouman@ne.mediaone.net> + +Copyright: distributable, see individual files for copyright +Vendor: Aubrey Jaffer <jaffer@ai.mit.edu> +Group: Development/Tools +Provides: slib +BuildArch: noarch + +Summary: platform independent library for scheme +Source: ftp://swissnet.ai.mit.edu/pub/scm/slib%{version}.zip +URL: http://swissnet.ai.mit.edu/~jaffer/SLIB.html +BuildRoot: %{_tmppath}/%{name}%{version} +Prefix: /usr/share + +%description +"SLIB" is a portable library for the programming language Scheme. +It provides a platform independent framework for using "packages" of +Scheme procedures and syntax. As distributed, SLIB contains useful +packages for all Scheme implementations. Its catalog can be +transparently extended to accomodate packages specific to a site, +implementation, user, or directory. + +%define __os_install_post /usr/lib/rpm/brp-compress + +%prep +%setup -n slib -c -T +cd .. +unzip $RPM_SOURCE_DIR/slib%{version}.zip + +%build +gzip -f slib.info + +%install +mkdir -p ${RPM_BUILD_ROOT}%{prefix}/slib +cp -r . ${RPM_BUILD_ROOT}%{prefix}/slib +mkdir -p ${RPM_BUILD_ROOT}/usr/info +cp slib.info.gz ${RPM_BUILD_ROOT}/usr/info + +%clean +rm -rf $RPM_BUILD_ROOT + +%post +/sbin/install-info /usr/info/slib.info.gz /usr/info/dir + +# This symlink is made as in the spec file of Robert J. Meier. +if [ -L /usr/share/guile/slib ]; then + rm /usr/share/guile/slib + ln -s %{prefix}/slib /usr/share/guile/slib +fi + +# This section should be extended to rebuild catalogs for as many +# implementations as possible. +if [ -x /usr/bin/guile ]; then + /usr/bin/guile -c "(use-modules (ice-9 slib)) (require 'new-catalog)" +fi +if [ -x /usr/bin/scm ]; then + /usr/bin/scm -c "(require 'new-catalog)" +fi + +%files +%defattr(-, root, root) +%dir %{prefix}/slib +%{prefix}/slib/*.scm +%{prefix}/slib/*.init +/usr/info/slib.info.gz +# The Makefile is included as it is useful for building documentation. +%{prefix}/slib/Makefile +%doc ANNOUNCE ChangeLog FAQ README + +%changelog +* Wed Mar 14 2001 Radey Shouman <shouman@ne.mediaone.net> +- Adapted from the spec file of R. J. Meier. + +* Mon Jul 12 2000 Dr. Robert J. Meier <robert.meier@computer.org> 0.9.4-1suse +- Packaged for SuSE 6.3 + +* Sun May 30 2000 Aubrey Jaffer <jaffer@ai.mit.edu> +- Updated content diff --git a/module/slib/slib.texi b/module/slib/slib.texi new file mode 100644 index 000000000..5194f47e5 --- /dev/null +++ b/module/slib/slib.texi @@ -0,0 +1,11142 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename slib.info +@settitle SLIB +@include version.txi +@setchapternewpage on +@c Choices for setchapternewpage are {on,off,odd}. +@paragraphindent 2 +@defcodeindex ft +@syncodeindex ft cp +@syncodeindex tp cp +@c %**end of header + +@dircategory The Algorithmic Language Scheme +@direntry +* SLIB: (slib). Scheme Library +@end direntry + +@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, 1996, 1997, 1998, 1999, 2000 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 + +@node Top, The Library System, (dir), (dir) + +@titlepage +@title SLIB +@subtitle The Portable Scheme Library +@subtitle Version @value{SLIBVERSION} +@author by Aubrey Jaffer +@page + +@noindent +@dfn{SLIB} is a portable library for the programming language +@dfn{Scheme}. It provides a platform independent framework for using +@dfn{packages} of Scheme procedures and syntax. As distributed, SLIB +contains useful packages for all Scheme implementations. Its catalog +can be transparently extended to accomodate packages specific to a site, +implementation, user, or directory. + +@noindent +More people than I can name have contributed to SLIB. Thanks to all of +you! +@sp 1 +@quotation +SLIB @value{SLIBVERSION}, released @value{SLIBDATE}.@* +Aubrey Jaffer <jaffer @@ ai.mit.edu>@* +@ifset html +<A HREF="http://swissnet.ai.mit.edu/~jaffer/SLIB.html"> +@end ifset +@url{http://swissnet.ai.mit.edu/~jaffer/SLIB.html} +@ifset html +</A> +@end ifset +@end quotation + +@ifclear html +@vskip 0pt plus 1filll +Copyright @copyright{} 1993 Todd R. Eigenschink@* +Copyright @copyright{} 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000 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 ifclear +@end titlepage + +@ifinfo +@noindent +@dfn{SLIB} is a portable library for the programming language +@dfn{Scheme}. It provides a platform independent framework for using +@dfn{packages} of Scheme procedures and syntax. As distributed, SLIB +contains useful packages for all Scheme implementations. Its catalog +can be transparently extended to accomodate packages specific to a site, +implementation, user, or directory. +@end ifinfo + +@menu +* The Library System:: How to use and customize. +* Scheme Syntax Extension Packages:: +* Textual Conversion Packages:: +* Mathematical Packages:: +* Database Packages:: +* Other Packages:: +* About SLIB:: Install, etc. +* Index:: +@end menu + +@node The Library System, Scheme Syntax Extension Packages, Top, Top +@chapter The Library System + +@menu +* Feature:: SLIB names. +* Requesting Features:: +* Library Catalogs:: +* Catalog Compilation:: +* Built-in Support:: +* About this manual:: +@end menu + + +@node Feature, Requesting Features, The Library System, The Library System +@section Feature + +@noindent +@cindex feature +SLIB denotes @dfn{features} by symbols. SLIB maintains a list of +features supported by the Scheme @dfn{session}. The set of features +@cindex session +provided by a session may change over time. Some features are +properties of the Scheme implementation being used. The following +features detail what sort of numbers are available from an +implementation. + +@itemize @bullet +@item +'inexact +@item +'rational +@item +'real +@item +'complex +@item +'bignum +@end itemize + +@noindent +Other features correspond to the presence of sets of Scheme procedures +or syntax (macros). + +@defun provided? feature +Returns @code{#t} if @var{feature} is supported by the current Scheme +session. +@end defun + +@deffn Procedure provide feature +Informs SLIB that @var{feature} is supported. Henceforth +@code{(provided? @var{feature})} will return @code{#t}. +@end deffn + +@example +(provided? 'foo) @result{} #f +(provide 'foo) +(provided? 'foo) @result{} #t +@end example + + +@node Requesting Features, Library Catalogs, Feature, The Library System +@section Requesting Features + +@noindent +@cindex catalog +SLIB creates and maintains a @dfn{catalog} mapping features to locations +of files introducing procedures and syntax denoted by those features. + +@noindent +At the beginning of each section of this manual, there is a line like +@code{(require '@var{feature})}. +@ftindex feature +The Scheme files comprising SLIB are cataloged so that these feature +names map to the corresponding files. + +@noindent +SLIB provides a form, @code{require}, which loads the files providing +the requested feature. + +@deffn Procedure require feature +@itemize @bullet +@item +If @code{(provided? @var{feature})} is true, +then @code{require} just returns an unspecified value. +@item +Otherwise, if @var{feature} is found in the catalog, then the +corresponding files will be loaded and an unspecified value returned. + +Subsequently @code{(provided? @var{feature})} will return @code{#t}. +@item +Otherwise (@var{feature} not found in the catalog), an error is +signaled. +@end itemize +@end deffn + +@noindent +The catalog can also be queried using @code{require:feature->path}. + +@defun require:feature->path feature +@itemize @bullet +@item +If @var{feature} is already provided, then returns @code{#t}. +@item +Otherwise, if @var{feature} is in the catalog, the path or list of paths +associated with @var{feature} is returned. +@item +Otherwise, returns @code{#f}. +@end itemize +@end defun + + +@node Library Catalogs, Catalog Compilation, Requesting Features, The Library System +@section Library Catalogs + +@noindent +At the start of a session no catalog is present, but is created with the +first catalog inquiry (such as @code{(require 'random)}). Several +sources of catalog information are combined to produce the catalog: + +@itemize @bullet +@item +standard SLIB packages. +@item +additional packages of interest to this site. +@item +packages specifically for the variety of Scheme which this +session is running. +@item +packages this user wants to always have available. This catalog is the +file @file{homecat} in the user's @dfn{HOME} directory. +@cindex HOME +@item +packages germane to working in this (current working) directory. This +catalog is the file @file{usercat} in the directory to which it applies. +One would typically @code{cd} to this directory before starting the +Scheme session. +@end itemize + +@noindent +Catalog files consist of one or more @dfn{association list}s. +@cindex Catalog File +In the circumstance where a feature symbol appears in more than one +list, the latter list's association is retrieved. Here are the +supported formats for elements of catalog lists: + +@table @code +@item (@var{feature} . @i{<symbol>}) +Redirects to the feature named @i{<symbol>}. +@item (@var{feature} . "@i{<path>}") +Loads file @i{<path>}. +@item (@var{feature} source "@i{<path>"}) +@code{slib:load}s the Scheme source file @i{<path>}. +@item (@var{feature} compiled "@i{<path>"} @dots{}) +@code{slib:load-compiled}s the files @i{<path>} @dots{}. +@end table + +@noindent +The various macro styles first @code{require} the named macro package, +then just load @i{<path>} or load-and-macro-expand @i{<path>} as +appropriate for the implementation. + +@table @code +@item (@var{feature} defmacro "@i{<path>"}) +@code{defmacro:load}s the Scheme source file @i{<path>}. +@item (@var{feature} macro-by-example "@i{<path>"}) +@code{defmacro:load}s the Scheme source file @i{<path>}. +@end table + +@table @code +@item (@var{feature} macro "@i{<path>"}) +@code{macro:load}s the Scheme source file @i{<path>}. +@item (@var{feature} macros-that-work "@i{<path>"}) +@code{macro:load}s the Scheme source file @i{<path>}. +@item (@var{feature} syntax-case "@i{<path>"}) +@code{macro:load}s the Scheme source file @i{<path>}. +@item (@var{feature} syntactic-closures "@i{<path>"}) +@code{macro:load}s the Scheme source file @i{<path>}. +@end table + +@noindent +Here is an example of a @file{usercat} catalog. A Program in this +directory can invoke the @samp{run} feature with @code{(require 'run)}. + +@example +;;; "usercat": SLIB catalog additions for SIMSYNCH. -*-scheme-*- + +( + (simsynch . "../synch/simsynch.scm") + (run . "../synch/run.scm") + (schlep . "schlep.scm") +) +@end example + + +@node Catalog Compilation, Built-in Support, Library Catalogs, The Library System +@section Catalog Compilation + + +@noindent +SLIB combines the catalog information which doesn't vary per user into +the file @file{slibcat} in the implementation-vicinity. Therefore +@file{slibcat} needs change only when new software is installed or +compiled. Because the actual pathnames of files can differ from +installation to installation, SLIB builds a separate catalog for each +implementation it is used with. + +@noindent +The definition of @code{*SLIB-VERSION*} in SLIB file @file{require.scm} +is checked against the catalog association of @code{*SLIB-VERSION*} to +ascertain when versions have changed. I recommend that the definition +of @code{*SLIB-VERSION*} be changed whenever the library is changed. If +multiple implementations of Scheme use SLIB, remember that recompiling +one @file{slibcat} will fix only that implementation's catalog. + +@noindent +The compilation scripts of Scheme implementations which work with SLIB +can automatically trigger catalog compilation by deleting +@file{slibcat} or by invoking a special form of @code{require}: + +@deffn Procedure require @r{'new-catalog} +@cindex new-catalog +This will load @file{mklibcat}, which compiles and writes a new +@file{slibcat}. +@end deffn + +@noindent +Another special form of @code{require} erases SLIB's catalog, forcing it +to be reloaded the next time the catalog is queried. + +@deffn Procedure require @r{#f} +Removes SLIB's catalog information. This should be done before saving +an executable image so that, when restored, its catalog will be loaded +afresh. +@end deffn + +@noindent +Each file in the table below is descibed in terms of its +file-system independent @dfn{vicinity} (@pxref{Vicinity}). The entries +of a catalog in the table override those of catalogs above it in the +table. + +@table @asis + +@item @code{implementation-vicinity} @file{slibcat} +@cindex slibcat +This file contains the associations for the packages comprising SLIB, +the @file{implcat} and the @file{sitecat}s. The associations in the +other catalogs override those of the standard catalog. + +@item @code{library-vicinity} @file{mklibcat.scm} +@cindex mklibcat.scm +creates @file{slibcat}. + +@item @code{library-vicinity} @file{sitecat} +@cindex sitecat +This file contains the associations specific to an SLIB installation. + +@item @code{implementation-vicinity} @file{implcat} +@cindex implcat +This file contains the associations specific to an implementation of +Scheme. Different implementations of Scheme should have different +@code{implementation-vicinity}. + +@item @code{implementation-vicinity} @file{mkimpcat.scm} +@cindex mkimpcat.scm +if present, creates @file{implcat}. + +@item @code{implementation-vicinity} @file{sitecat} +@cindex sitecat +This file contains the associations specific to a Scheme implementation +installation. + +@item @code{home-vicinity} @file{homecat} +@cindex homecat +This file contains the associations specific to an SLIB user. + +@item @code{user-vicinity} @file{usercat} +@cindex usercat +This file contains associations effecting only those sessions whose +@dfn{working directory} is @code{user-vicinity}. + +@end table + +@node Built-in Support, About this manual, Catalog Compilation, The Library System +@section Built-in Support + +@noindent +The procedures described in these sections are supported by all +implementations as part of the @samp{*.init} files or by +@file{require.scm}. + +@menu +* 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 Require, Vicinity, Built-in Support, Built-in Support +@subsection Require + +@defvar *features* +Is a list of symbols denoting features supported in this implementation. +@var{*features*} can grow as modules are @code{require}d. +@var{*features*} must be defined by all implementations +(@pxref{Porting}). + +Here are features which SLIB (@file{require.scm}) adds to +@var{*features*} when appropriate. + +@itemize @bullet +@item +'inexact +@item +'rational +@item +'real +@item +'complex +@item +'bignum +@end itemize + +For each item, @code{(provided? '@var{feature})} will return @code{#t} +if that feature is available, and @code{#f} if not. +@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 + +@noindent +In the following functions if the argument @var{feature} is not a symbol +it is assumed to be a pathname. + +@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. +@end defun + +@deffn Procedure require feature +@var{feature} is a symbol. If @code{(provided? @var{feature})} is true +@code{require} returns. Otherwise, if @code{(assq @var{feature} +*catalog*)} is not @code{#f}, the associated files will be loaded and +@code{(provided? @var{feature})} will henceforth return @code{#t}. An +unspecified value is returned. If @var{feature} is not found in +@code{*catalog*}, then an error is signaled. + +@deffnx Procedure require pathname +@var{pathname} is a string. If @var{pathname} has not already been +given as an argument to @code{require}, @var{pathname} is loaded. An +unspecified value is returned. +@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. +@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 + + + + +@node Vicinity, Configuration, Require, Built-in Support +@subsection Vicinity + +@noindent +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. + +@noindent +These procedures are provided by all implementations. + +@defun make-vicinity path +Returns the vicinity of @var{path} 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 incorrect values if your program escapes back into a +@code{load}. +@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 + +@defun home-vicinity +Returns the vicinity of the user's @dfn{HOME} directory, the directory +@cindex HOME +which typically contains files which customize a computer environment +for a user. If scheme is running without a user (eg. a daemon) or if +this concept is meaningless for the platform, then @code{home-vicinity} +returns @code{#f}. +@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}. +@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}. +@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}. +@end defun + + + +@node Configuration, Input/Output, Vicinity, Built-in Support +@subsection Configuration + +@noindent +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}. +@end defvr + +@defvr Constant most-positive-fixnum +In implementations which support integers of practically unlimited size, +@var{most-positive-fixnum} is a large exact integer within the range of +exact integers that may result from computing the length of a list, +vector, or string. + +In implementations which do not support integers of practically +unlimited size, @var{most-positive-fixnum} is the largest exact integer +that may result from computing the length of a list, vector, or string. +@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 "@value{SLIBVERSION}" on scm "5b1" 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 "@value{SLIBVERSION}" on scm "5b1" on unix +(implementation-vicinity) is "/home/jaffer/scm/" +(library-vicinity) is "/home/jaffer/slib/" +(scheme-file-suffix) is ".scm" +loaded *features* : + trace alist qp sort + common-list-functions macro values getopt + compiled +implementation *features* : + bignum complex real rational + inexact vicinity ed getenv + tmpnam 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 current-time record + rev3-procedures rev2-procedures sun-dl string-case + array dump char-ready? full-continuation + system +implementation *catalog* : + (i/o-extensions compiled "/home/jaffer/scm/ioext.so") + ... +@end example +@end defun + +@node Input/Output, Legacy, Configuration, Built-in Support +@subsection Input/Output + +@noindent +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. +@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. +@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)}. +@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. +@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. +@end deffn + +@node Legacy, System, Input/Output, Built-in Support +@subsection Legacy + +These procedures are provided by all implementations. + +@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 + +@noindent +The following procedures were present in Scheme until R4RS +(@pxref{Notes, , Language changes ,r4rs, Revised(4) Scheme}). +They are provided by all SLIB implementations. + +@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, Built-in Support +@subsection System + +@noindent +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. @ref{Eval} provides a more general evaluation +facility. +@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}. +@end deffn + +@deffn Procedure slib:warn arg1 arg2 @dots{} +Outputs a warning message containing the arguments. +@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. +@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 About this manual, , Built-in Support, The Library System +@section About this manual + +@itemize @bullet +@item +Entries that are labeled as Functions are called for their return +values. Entries that are labeled as Procedures are called primarily for +their side effects. + +@item +Examples in this text were produced using the @code{scm} Scheme +implementation. + +@item +At the beginning of each section, there is a line that looks like +@ftindex feature +@code{(require 'feature)}. Include this line in your code prior to +using the package. +@end itemize + + +@node Scheme Syntax Extension Packages, Textual Conversion Packages, The Library System, Top +@chapter Scheme Syntax Extension Packages + +@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, Scheme Syntax Extension Packages, Scheme Syntax Extension Packages +@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}. +@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{defmacro} 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)} +@ftindex 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, Scheme Syntax Extension Packages +@section R4RS Macros + +@code{(require 'macro)} is the appropriate call if you want R4RS +@ftindex macro +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}. +@end deffn + +@node Macro by Example, Macros That Work, R4RS Macros, Scheme Syntax Extension Packages +@section Macro by Example + +@code{(require 'macro-by-example)} +@ftindex 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, Scheme Syntax Extension Packages +@section Macros That Work + +@code{(require 'macros-that-work)} +@ftindex 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. +@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}. +@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. + +@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, Scheme Syntax Extension Packages +@section Syntactic Closures + +@code{(require 'syntactic-closures)} +@ftindex 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. +@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. +@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}. +@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}. + +@subsubsection Terminology + +This section defines the concepts and data types used by the syntactic +closures facility. + +@itemize @bullet + +@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. + +@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. + +@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. + +@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}. + +@deffn Syntax transformer expression + +Syntax: It is an error if this syntax occurs except as a +@var{transformer spec}. + +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}). + +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. + +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}. + +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. +@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}. + +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. +@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. + +To obtain a syntactic environment other than the usage environment, use +@code{capture-syntactic-environment}. +@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. + +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. + +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}. + +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. + +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. + +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. +@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. + + + + + +@node Syntax-Case Macros, Fluid-Let, Syntactic Closures, Scheme Syntax Extension Packages +@section Syntax-Case Macros + +@code{(require 'syntax-case)} +@ftindex 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. +@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. +@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}. +@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}. + +In order to use syntax-case from an interactive top level, execute: +@lisp +(require 'syntax-case) +@ftindex syntax-case +(require 'repl) +@ftindex repl +(repl:top-level macro:eval) +@end lisp +See the section Repl (@pxref{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) +@ftindex 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}. + +@code{syntax-rules} and @code{with-syntax} (described in @cite{TR356}) +are defined. + +@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. + +Several other top-level bindings not documented in TR356 are created: +@itemize @bullet +@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. + +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. + +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, Scheme Syntax Extension Packages +@section Fluid-Let + +@code{(require 'fluid-let)} +@ftindex 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. + +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}. + + +@node Yasos, , Fluid-Let, Scheme Syntax Extension Packages +@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)} +@ftindex oop +@ftindex 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]. + +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. + +@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. +@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 behavior (for an empty +@var{default-body}) is to generate an error. +@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. +@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{}. +@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''. +@end deffn + +@deffn Procedure print obj port +A default @code{print} operation is provided which is just @code{(format +@var{port} @var{obj})} (@pxref{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 +(@pxref{Collections}) may override the default in an obvious way. +@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 (@pxref{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 +;;; These definitions for PRINT and SIZE are +;;; already supplied by +(require 'yasos) + +(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 Textual Conversion Packages, Mathematical Packages, Scheme Syntax Extension Packages, Top +@chapter Textual Conversion Packages + +@menu +* Precedence Parsing:: +* Format:: Common-Lisp Format +* Standard Formatted I/O:: Posix printf and scanf +* Programs and Arguments:: +* HTML:: +* HTML Tables:: Databases meet HTML +* HTTP and CGI:: Serve WWW sites +* URI:: Uniform Resource Identifier +* Printing Scheme:: Nicely +* Time and Date:: +* Vector Graphics:: +* Schmooz:: Documentation markup for Scheme programs +@end menu + + +@node Precedence Parsing, Format, Textual Conversion Packages, Textual Conversion Packages +@section Precedence Parsing + +@code{(require 'precedence-parse)} or @code{(require 'parse)} +@ftindex parse +@ftindex precedence + +@noindent +This package implements: + +@itemize @bullet +@item +a Pratt style precedence parser; +@item +a @dfn{tokenizer} which congeals tokens according to assigned classes of +constituent characters; +@item +procedures giving direct control of parser rulesets; +@item +procedures for higher level specification of rulesets. +@end itemize + +@menu +* Precedence Parsing Overview:: +* Ruleset Definition and Use:: +* Token definition:: +* Nud and Led Definition:: +* Grammar Rule Definition:: +@end menu + +@node Precedence Parsing Overview, Ruleset Definition and Use, Precedence Parsing, Precedence Parsing +@subsection Precedence Parsing Overview + +@noindent +This package offers improvements over previous parsers. + +@itemize @bullet +@item +Common computer language constructs are concisely specified. +@item +Grammars can be changed dynamically. Operators can be assigned +different meanings within a lexical context. +@item +Rulesets don't need compilation. Grammars can be changed incrementally. +@item +Operator precedence is specified by integers. +@item +All possibilities of bad input are handled @footnote{How do I know this? +I parsed 250kbyte of random input (an e-mail file) with a non-trivial +grammar utilizing all constructs.} and return as much structure as was +parsed when the error occured; The symbol @code{?} is substituted for +missing input. +@end itemize + +@noindent +Here are the higher-level syntax types and an example of each. +Precedence considerations are omitted for clarity. See @ref{Grammar +Rule Definition} for full details. +@deftp Grammar nofix bye exit +@example +bye +@end example +calls the function @code{exit} with no arguments. +@end deftp +@deftp Grammar prefix - negate +@example +- 42 +@end example +Calls the function @code{negate} with the argument @code{42}. +@end deftp +@deftp Grammar infix - difference +@example +x - y +@end example +Calls the function @code{difference} with arguments @code{x} and @code{y}. +@end deftp +@deftp Grammar nary + sum +@example +x + y + z +@end example +Calls the function @code{sum} with arguments @code{x}, @code{y}, and +@code{y}. +@end deftp +@deftp Grammar postfix ! factorial +@example +5 ! +@end example +Calls the function @code{factorial} with the argument @code{5}. +@end deftp +@deftp Grammar prestfix set set! +@example +set foo bar +@end example +Calls the function @code{set!} with the arguments @code{foo} and +@code{bar}. +@end deftp +@deftp Grammar commentfix /* */ +@example +/* almost any text here */ +@end example +Ignores the comment delimited by @code{/*} and @code{*/}. +@end deftp +@deftp Grammar matchfix @{ list @} +@example +@{0, 1, 2@} +@end example +Calls the function @code{list} with the arguments @code{0}, @code{1}, +and @code{2}. +@end deftp +@deftp Grammar inmatchfix ( funcall ) +@example +f(x, y) +@end example +Calls the function @code{funcall} with the arguments @code{f}, @code{x}, +and @code{y}. +@end deftp +@deftp Grammar delim ; +@example +set foo bar; +@end example +delimits the extent of the restfix operator @code{set}. +@end deftp + + +@node Ruleset Definition and Use, Token definition, Precedence Parsing Overview, Precedence Parsing +@subsection Ruleset Definition and Use + +@defvar *syn-defs* +A grammar is built by one or more calls to @code{prec:define-grammar}. +The rules are appended to @var{*syn-defs*}. The value of +@var{*syn-defs*} is the grammar suitable for passing as an argument to +@code{prec:parse}. +@end defvar + +@defvr Constant *syn-ignore-whitespace* +Is a nearly empty grammar with whitespace characters set to group 0, +which means they will not be made into tokens. Most rulesets will want +to start with @code{*syn-ignore-whitespace*} +@end defvr + +@noindent +In order to start defining a grammar, either + +@example +(set! *syn-defs* '()) +@end example +@noindent +or + +@example +(set! *syn-defs* *syn-ignore-whitespace*) +@end example + +@defun prec:define-grammar rule1 @dots{} +Appends @var{rule1} @dots{} to @var{*syn-defs*}. +@code{prec:define-grammar} is used to define both the character classes +and rules for tokens. +@end defun + +@noindent +Once your grammar is defined, save the value of @code{*syn-defs*} in a +variable (for use when calling @code{prec:parse}). + +@example +(define my-ruleset *syn-defs*) +@end example + +@defun prec:parse ruleset delim +@defunx prec:parse ruleset delim port +The @var{ruleset} argument must be a list of rules as constructed by +@code{prec:define-grammar} and extracted from @var{*syn-defs*}. + +The token @var{delim} may be a character, symbol, or string. A +character @var{delim} argument will match only a character token; i.e. a +character for which no token-group is assigned. A symbols or string +will match only a token string; i.e. a token resulting from a token +group. + +@code{prec:parse} reads a @var{ruleset} grammar expression delimited +by @var{delim} from the given input @var{port}. @code{prec:parse} +returns the next object parsable from the given input @var{port}, +updating @var{port} to point to the first character past the end of the +external representation of the object. + +If an end of file is encountered in the input before any characters are +found that can begin an object, then an end of file object is returned. +If a delimiter (such as @var{delim}) is found before any characters are +found that can begin an object, then @code{#f} is returned. + +The @var{port} argument may be omitted, in which case it defaults to the +value returned by @code{current-input-port}. It is an error to parse +from a closed port. +@findex current-input-port +@end defun + +@node Token definition, Nud and Led Definition, Ruleset Definition and Use, Precedence Parsing +@subsection Token definition + +@defun tok:char-group group chars chars-proc +The argument @var{chars} may be a single character, a list of +characters, or a string. Each character in @var{chars} is treated as +though @code{tok:char-group} was called with that character alone. + +The argument @var{chars-proc} must be a procedure of one argument, a +list of characters. After @code{tokenize} has finished +accumulating the characters for a token, it calls @var{chars-proc} with +the list of characters. The value returned is the token which +@code{tokenize} returns. + +The argument @var{group} may be an exact integer or a procedure of one +character argument. The following discussion concerns the treatment +which the tokenizing routine, @code{tokenize}, will accord to characters +on the basis of their groups. + +When @var{group} is a non-zero integer, characters whose group number is +equal to or exactly one less than @var{group} will continue to +accumulate. Any other character causes the accumulation to stop (until +a new token is to be read). + +The @var{group} of zero is special. These characters are ignored when +parsed pending a token, and stop the accumulation of token characters +when the accumulation has already begun. Whitespace characters are +usually put in group 0. + +If @var{group} is a procedure, then, when triggerd by the occurence of +an initial (no accumulation) @var{chars} character, this procedure will +be repeatedly called with each successive character from the input +stream until the @var{group} procedure returns a non-false value. +@end defun + +@noindent +The following convenient constants are provided for use with +@code{tok:char-group}. + +@defvr Constant tok:decimal-digits +Is the string @code{"0123456789"}. +@end defvr +@defvr Constant tok:upper-case +Is the string consisting of all upper-case letters +("ABCDEFGHIJKLMNOPQRSTUVWXYZ"). +@end defvr +@defvr Constant tok:lower-case +Is the string consisting of all lower-case letters +("abcdefghijklmnopqrstuvwxyz"). +@end defvr +@defvr Constant tok:whitespaces +Is the string consisting of all characters between 0 and 255 for which +@code{char-whitespace?} returns true. +@end defvr + + +@node Nud and Led Definition, Grammar Rule Definition, Token definition, Precedence Parsing +@subsection Nud and Led Definition + +This section describes advanced features. You can skip this section on +first reading. + +@noindent +The @dfn{Null Denotation} (or @dfn{nud}) +@cindex Null Denotation, nud +of a token is the procedure and arguments applying for that token when +@dfn{Left}, an unclaimed parsed expression is not extant. + +@noindent +The @dfn{Left Denotation} (or @dfn{led}) +@cindex Left Denotation, led +of a token is the procedure, arguments, and lbp applying for that token +when there is a @dfn{Left}, an unclaimed parsed expression. + +@noindent +In his paper, + +@quotation +Pratt, V. R. +Top Down Operator Precendence. +@cite{SIGACT/SIGPLAN Symposium on Principles of Programming Languages}, +Boston, 1973, pages 41-51 +@end quotation + +the @dfn{left binding power} (or @dfn{lbp}) was an independent property +of tokens. I think this was done in order to allow tokens with NUDs but +not LEDs to also be used as delimiters, which was a problem for +statically defined syntaxes. It turns out that @emph{dynamically +binding} NUDs and LEDs allows them independence. + +@noindent +For the rule-defining procedures that follow, the variable @var{tk} may +be a character, string, or symbol, or a list composed of characters, +strings, and symbols. Each element of @var{tk} is treated as though the +procedure were called for each element. + +@noindent +Character @var{tk} arguments will match only character tokens; +i.e. characters for which no token-group is assigned. Symbols and +strings will both match token strings; i.e. tokens resulting from token +groups. + +@defun prec:make-nud tk sop arg1 @dots{} +Returns a rule specifying that @var{sop} be called when @var{tk} is +parsed. If @var{sop} is a procedure, it is called with @var{tk} and +@var{arg1} @dots{} as its arguments; the resulting value is incorporated +into the expression being built. Otherwise, @code{(list @var{sop} +@var{arg1} @dots{})} is incorporated. +@end defun + +@noindent +If no NUD has been defined for a token; then if that token is a string, +it is converted to a symbol and returned; if not a string, the token is +returned. + +@defun prec:make-led tk sop arg1 @dots{} +Returns a rule specifying that @var{sop} be called when @var{tk} is +parsed and @var{left} has an unclaimed parsed expression. If @var{sop} +is a procedure, it is called with @var{left}, @var{tk}, and @var{arg1} +@dots{} as its arguments; the resulting value is incorporated into the +expression being built. Otherwise, @var{left} is incorporated. +@end defun + +@noindent +If no LED has been defined for a token, and @var{left} is set, the +parser issues a warning. + +@node Grammar Rule Definition, , Nud and Led Definition, Precedence Parsing +@subsection Grammar Rule Definition + +@noindent +Here are procedures for defining rules for the syntax types introduced +in @ref{Precedence Parsing Overview}. + +@noindent +For the rule-defining procedures that follow, the variable @var{tk} may +be a character, string, or symbol, or a list composed of characters, +strings, and symbols. Each element of @var{tk} is treated as though the +procedure were called for each element. + +@noindent +For procedures prec:delim, @dots{}, prec:prestfix, if the @var{sop} +argument is @code{#f}, then the token which triggered this rule is +converted to a symbol and returned. A false @var{sop} argument to the +procedures prec:commentfix, prec:matchfix, or prec:inmatchfix has a +different meaning. + +@noindent +Character @var{tk} arguments will match only character tokens; +i.e. characters for which no token-group is assigned. Symbols and +strings will both match token strings; i.e. tokens resulting from token +groups. + +@defun prec:delim tk +Returns a rule specifying that @var{tk} should not be returned from +parsing; i.e. @var{tk}'s function is purely syntactic. The end-of-file +is always treated as a delimiter. +@end defun + +@defun prec:nofix tk sop +Returns a rule specifying the following actions take place when @var{tk} +is parsed: +@itemize @bullet +@item +If @var{sop} is a procedure, it is called with no arguments; the +resulting value is incorporated into the expression being built. +Otherwise, the list of @var{sop} is incorporated. +@end itemize +@end defun + +@defun prec:prefix tk sop bp rule1 @dots{} +Returns a rule specifying the following actions take place when @var{tk} +is parsed: +@itemize @bullet +@item +The rules @var{rule1} @dots{} augment and, in case of conflict, override +rules currently in effect. +@item +@code{prec:parse1} is called with binding-power @var{bp}. +@item +If @var{sop} is a procedure, it is called with the expression returned +from @code{prec:parse1}; the resulting value is incorporated into the +expression being built. Otherwise, the list of @var{sop} and the +expression returned from @code{prec:parse1} is incorporated. +@item +The ruleset in effect before @var{tk} was parsed is restored; +@var{rule1} @dots{} are forgotten. +@end itemize +@end defun + +@defun prec:infix tk sop lbp bp rule1 @dots{} +Returns a rule declaring the left-binding-precedence of the token +@var{tk} is @var{lbp} and specifying the following actions take place +when @var{tk} is parsed: +@itemize @bullet +@item +The rules @var{rule1} @dots{} augment and, in case of conflict, override +rules currently in effect. +@item +One expression is parsed with binding-power @var{lbp}. If instead a +delimiter is encountered, a warning is issued. +@item +If @var{sop} is a procedure, it is applied to the list of @var{left} and +the parsed expression; the resulting value is incorporated into the +expression being built. Otherwise, the list of @var{sop}, the +@var{left} expression, and the parsed expression is incorporated. +@item +The ruleset in effect before @var{tk} was parsed is restored; +@var{rule1} @dots{} are forgotten. +@end itemize +@end defun + +@defun prec:nary tk sop bp +Returns a rule declaring the left-binding-precedence of the token +@var{tk} is @var{bp} and specifying the following actions take place +when @var{tk} is parsed: +@itemize @bullet +@item +Expressions are parsed with binding-power @var{bp} as far as they are +interleaved with the token @var{tk}. +@item +If @var{sop} is a procedure, it is applied to the list of @var{left} and +the parsed expressions; the resulting value is incorporated into the +expression being built. Otherwise, the list of @var{sop}, the +@var{left} expression, and the parsed expressions is incorporated. +@end itemize +@end defun + +@defun prec:postfix tk sop lbp +Returns a rule declaring the left-binding-precedence of the token +@var{tk} is @var{lbp} and specifying the following actions take place +when @var{tk} is parsed: +@itemize @bullet +@item +If @var{sop} is a procedure, it is called with the @var{left} expression; +the resulting value is incorporated into the expression being built. +Otherwise, the list of @var{sop} and the @var{left} expression is +incorporated. +@end itemize +@end defun + +@defun prec:prestfix tk sop bp rule1 @dots{} +Returns a rule specifying the following actions take place when @var{tk} +is parsed: +@itemize @bullet +@item +The rules @var{rule1} @dots{} augment and, in case of conflict, override +rules currently in effect. +@item +Expressions are parsed with binding-power @var{bp} until a delimiter is +reached. +@item +If @var{sop} is a procedure, it is applied to the list of parsed +expressions; the resulting value is incorporated into the expression +being built. Otherwise, the list of @var{sop} and the parsed +expressions is incorporated. +@item +The ruleset in effect before @var{tk} was parsed is restored; +@var{rule1} @dots{} are forgotten. +@end itemize +@end defun + +@defun prec:commentfix tk stp match rule1 @dots{} +Returns rules specifying the following actions take place when @var{tk} +is parsed: +@itemize @bullet +@item +The rules @var{rule1} @dots{} augment and, in case of conflict, override +rules currently in effect. +@item +Characters are read until and end-of-file or a sequence of characters +is read which matches the @emph{string} @var{match}. +@item +If @var{stp} is a procedure, it is called with the string of all that +was read between the @var{tk} and @var{match} (exclusive). +@item +The ruleset in effect before @var{tk} was parsed is restored; +@var{rule1} @dots{} are forgotten. +@end itemize + +Parsing of commentfix syntax differs from the others in several ways. +It reads directly from input without tokenizing; It calls @var{stp} but +does not return its value; nay any value. I added the @var{stp} +argument so that comment text could be echoed. +@end defun + +@defun prec:matchfix tk sop sep match rule1 @dots{} +Returns a rule specifying the following actions take place when @var{tk} +is parsed: +@itemize @bullet +@item +The rules @var{rule1} @dots{} augment and, in case of conflict, override +rules currently in effect. +@item +A rule declaring the token @var{match} a delimiter takes effect. +@item +Expressions are parsed with binding-power @code{0} until the token +@var{match} is reached. If the token @var{sep} does not appear between +each pair of expressions parsed, a warning is issued. +@item +If @var{sop} is a procedure, it is applied to the list of parsed +expressions; the resulting value is incorporated into the expression +being built. Otherwise, the list of @var{sop} and the parsed +expressions is incorporated. +@item +The ruleset in effect before @var{tk} was parsed is restored; +@var{rule1} @dots{} are forgotten. +@end itemize +@end defun + +@defun prec:inmatchfix tk sop sep match lbp rule1 @dots{} +Returns a rule declaring the left-binding-precedence of the token +@var{tk} is @var{lbp} and specifying the following actions take place +when @var{tk} is parsed: +@itemize @bullet +@item +The rules @var{rule1} @dots{} augment and, in case of conflict, override +rules currently in effect. +@item +A rule declaring the token @var{match} a delimiter takes effect. +@item +Expressions are parsed with binding-power @code{0} until the token +@var{match} is reached. If the token @var{sep} does not appear between +each pair of expressions parsed, a warning is issued. +@item +If @var{sop} is a procedure, it is applied to the list of @var{left} and +the parsed expressions; the resulting value is incorporated into the +expression being built. Otherwise, the list of @var{sop}, the +@var{left} expression, and the parsed expressions is incorporated. +@item +The ruleset in effect before @var{tk} was parsed is restored; +@var{rule1} @dots{} are forgotten. +@end itemize +@end defun + + +@node Format, Standard Formatted I/O, Precedence Parsing, Textual Conversion Packages +@section Format (version 3.0) + +@code{(require 'format)} +@ftindex format + +@include fmtdoc.txi + +@node Standard Formatted I/O, Programs and Arguments, Format, Textual Conversion Packages +@section Standard Formatted I/O + +@menu +* Standard Formatted Output:: 'printf +* Standard Formatted Input:: 'scanf +@end menu + +@subsection stdio + +@code{(require 'stdio)} +@ftindex 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)} +@ftindex printf + +@deffn Procedure printf format arg1 @dots{} +@deffnx Procedure fprintf port format arg1 @dots{} +@deffnx Procedure sprintf str format arg1 @dots{} +@deffnx Procedure sprintf #f format arg1 @dots{} +@deffnx Procedure sprintf k 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. + +Two extensions of @code{sprintf} return new strings. If the first +argument is @code{#f}, then the returned string's length is as many +characters as specified by the @var{format} and data; if the first +argument is a non-negative integer @var{k}, then the length of the +returned string is also bounded by @var{k}. + +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 + +@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 fixed or exponential notation, +whichever is more appropriate for its magnitude. Unless an @samp{#} +flag has been supplied, trailing zeros after a decimal point will be +stripped off. @samp{%g} prints @samp{e} between mantissa and exponont. +@samp{%G} prints @samp{E} between mantissa and exponent. + +@item @samp{k}, @samp{K} +Print a number like @samp{%g}, except that an SI prefix is output after +the number, which is scaled accordingly. @samp{%K} outputs a space +between number and prefix, @samp{%k} does not. + +@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. See @ref{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)} +@ftindex 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 Programs and Arguments, HTML, Standard Formatted I/O, Textual Conversion Packages +@section Program and Arguments + +@menu +* Getopt:: Command Line option parsing +* Command Line:: A command line reader for Scheme shells +* Parameter lists:: 'parameters +* Getopt Parameter lists:: 'getopt-parameters +* Filenames:: 'glob or 'filename +* Batch:: 'batch +@end menu + +@node Getopt, Command Line, Programs and Arguments, Programs and Arguments +@subsection Getopt + +@code{(require 'getopt)} +@ftindex 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) +@ftindex 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 + +@subsection 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) +@ftindex 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, Parameter lists, Getopt, Programs and Arguments +@subsection Command Line + +@code{(require 'read-command)} +@ftindex read-command + +@defun read-command port +@defunx read-command +@code{read-command} converts a @dfn{command line} into a list of strings +@cindex command line +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 + +@defun read-options-file filename +@code{read-options-file} converts an @dfn{options file} into a list of +@cindex options file +strings suitable for parsing by @code{getopt}. The syntax of options +files is the same as the syntax for command +lines, except that @key{newline}s do not terminate reading (only @key{;} +or end of file). + +If an end of file is encountered before any characters are found that +can begin an object or comment, then an end of file object is returned. +@end defun + + + +@node Parameter lists, Getopt Parameter lists, Command Line, Programs and Arguments +@subsection Parameter lists + +@code{(require 'parameters)} +@ftindex 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 Function remove-parameter parameter-name parameter-list +Removes the parameter @var{parameter-name} from @var{parameter-list}. +@code{remove-parameter} does not alter the argument +@var{parameter-list}. + +If there are more than one @var{parameter-name} parameters, an error is +signaled. +@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 defaulters parameter-list +@var{defaulters} 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{fill-empty-parameters} +returns a new parameter-list with each empty parameter replaced with the +list returned by calling the corresponding @var{defaulter} with +@var{parameter-list} as its argument. +@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} a warning 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 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). + +@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 + + +@node Getopt Parameter lists, Filenames, Parameter lists, Programs and Arguments +@subsection Getopt Parameter lists + +@code{(require 'getopt-parameters)} + +@deffn Function getopt->parameter-list argc argv optnames arities types aliases desc @dots{} +Returns @var{argv} converted to a parameter-list. @var{optnames} are +the parameter-names. @var{arities} and @var{types} are lists of symbols +corresponding to @var{optnames}. + +@var{aliases} is a list of lists of strings or integers paired with +elements of @var{optnames}. Each one-character string will be treated +as a single @samp{-} option by @code{getopt}. Longer strings will be +treated as long-named options (@pxref{Getopt, getopt--}). + +If the @var{aliases} association list has only strings as its +@code{car}s, then all the option-arguments after an option (and before +the next option) are adjoined to that option. + +If the @var{aliases} association list has integers, then each (string) +option will take at most one option-argument. Unoptioned arguments are +collected in a list. A @samp{-1} alias will take the last argument in +this list; @samp{+1} will take the first argument in the list. The +aliases -2 then +2; -3 then +3; @dots{} are tried so long as a positive +or negative consecutive alias is found and arguments remain in the list. +Finally a @samp{0} alias, if found, absorbs any remaining arguments. + +In all cases, if unclaimed arguments remain after processing, a warning +is signaled and #f is returned. +@end deffn + +@deffn Function getopt->arglist argc argv optnames positions arities types defaulters checks aliases desc @dots{} +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{defaulters}, @var{checks}, and +@var{aliases}. If the options supplied violate the @var{arities} or +@var{checks} constraints, then a warning is signaled and #f is returned. +@end deffn + +@noindent +These @code{getopt} functions can be used with SLIB relational +databases. For an example, @xref{Database Utilities, +make-command-server}. + +@noindent +If errors are encountered while processing options, directions for using +the options (and argument strings @var{desc} @dots{}) are printed to +@code{current-error-port}. + +@example +(begin + (set! *optind* 1) + (getopt->parameter-list + 2 + '("cmd" "-?") + '(flag number symbols symbols string flag2 flag3 num2 num3) + '(boolean optional nary1 nary single boolean boolean nary nary) + '(boolean integer symbol symbol string boolean boolean integer integer) + '(("flag" flag) + ("f" flag) + ("Flag" flag2) + ("B" flag3) + ("optional" number) + ("o" number) + ("nary1" symbols) + ("N" symbols) + ("nary" symbols) + ("n" symbols) + ("single" string) + ("s" string) + ("a" num2) + ("Abs" num3)))) +@print{} +Usage: cmd [OPTION ARGUMENT ...] ... + + -f, --flag + -o, --optional=<number> + -n, --nary=<symbols> ... + -N, --nary1=<symbols> ... + -s, --single=<string> + --Flag + -B + -a <num2> ... + --Abs=<num3> ... + +ERROR: getopt->parameter-list "unrecognized option" "-?" +@end example + + +@node Filenames, Batch, Getopt Parameter lists, Programs and Arguments +@subsection Filenames + +@code{(require 'filename)} or @code{(require 'glob)} + +@defun filename:match?? pattern +@defunx filename:match-ci?? pattern +Returns a predicate which returns a non-false value if its string argument +matches (the string) @var{pattern}, false otherwise. Filename matching +is like +@cindex glob +@dfn{glob} expansion described the bash manpage, except that names +beginning with @samp{.} are matched and @samp{/} characters are not +treated specially. + +These functions interpret the following characters specially in +@var{pattern} strings: +@table @samp +@item * +Matches any string, including the null string. +@item ? +Matches any single character. +@item [@dots{}] +Matches any one of the enclosed characters. A pair of characters +separated by a minus sign (-) denotes a range; any character lexically +between those two characters, inclusive, is matched. If the first +character following the @samp{[} is a @samp{!} or a @samp{^} then any +character not enclosed is matched. A @samp{-} or @samp{]} may be +matched by including it as the first or last character in the set. +@end table + +@example +@end example +@end defun + +@defun filename:substitute?? pattern template +@defunx filename:substitute-ci?? pattern template +Returns a function transforming a single string argument according to +glob patterns @var{pattern} and @var{template}. @var{pattern} and +@var{template} must have the same number of wildcard specifications, +which need not be identical. @var{pattern} and @var{template} may have +a different number of literal sections. If an argument to the function +matches @var{pattern} in the sense of @code{filename:match??} then it +returns a copy of @var{template} in which each wildcard specification is +replaced by the part of the argument matched by the corresponding +wildcard specification in @var{pattern}. A @code{*} wildcard matches +the longest leftmost string possible. If the argument does not match +@var{pattern} then false is returned. + +@var{template} may be a function accepting the same number of string +arguments as there are wildcard specifications in @var{pattern}. In +the case of a match the result of applying @var{template} to a list +of the substrings matched by wildcard specifications will be returned, +otherwise @var{template} will not be called and @code{#f} will be returned. + +@example +((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm") + "scm_10.html") +@result{} "scm5c4_10.htm" +((filename:substitute?? "??" "beg?mid?end") "AZ") +@result{} "begAmidZend" +((filename:substitute?? "*na*" "?NA?") "banana") +@result{} "banaNA" +((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1))) "ABZ") +@result{} "ZA" +@end example +@end defun + +@defun replace-suffix str old new +@var{str} can be a string or a list of strings. Returns a new string +(or strings) 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. + +@example +(replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c") +@result{} "/usr/local/lib/slib/batch.c" +@end example +@end defun + + +@node Batch, , Filenames, Programs and Arguments +@subsection Batch + +@code{(require 'batch)} +@ftindex 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 +amigados +@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 + +@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:command parms string1 string2 @dots{} +Calls @code{batch:try-command} (below) with arguments, but signals an +error if @code{batch:try-command} 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-command 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:try-chopped-command parms arg1 arg2 @dots{} list +breaks the last argument @var{list} into chunks small enough so that the +command: + +@example +@var{arg1} @var{arg2} @dots{} @var{chunk} +@end example + +fits withing the platform's maximum command-line length. + +@code{batch:try-chopped-command} calls @code{batch:try-command} with the +command and returns non-false only if the commands all fit and +@code{batch:try-command} of each command line returned non-false. +@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-command} 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 truncate-up-to path char +@defunx truncate-up-to path string +@defunx truncate-up-to path charlist +@var{path} can be a string or a list of strings. Returns @var{path} +sans any prefixes ending with a character of the second argument. This +can be used to derive a filename moved locally from elsewhere. + +@example +(truncate-up-to "/usr/local/lib/slib/batch.scm" "/") +@result{} "batch.scm" +@end example +@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) +@ftindex database-utilities +(require 'parameters) +@ftindex parameters +(require 'batch) +@ftindex batch +(require 'glob) +@ftindex glob + +(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:command my-parameters "cc" "-c" "hello.c") + (batch:command my-parameters "cc" "-o" "hello" + (replace-suffix "hello.c" ".c" ".o")) + (batch:command 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" script created by SLIB/batch Sun Oct 31 18:24:10 1999 +# ================ 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 HTML, HTML Tables, Programs and Arguments, Textual Conversion Packages +@section HTML + +@include htmlform.txi + + +@node HTML Tables, HTTP and CGI, HTML, Textual Conversion Packages +@section HTML Tables + +@include db2html.txi + + +@node HTTP and CGI, URI, HTML Tables, Textual Conversion Packages +@section HTTP and CGI + +@include http-cgi.txi + + +@node URI, Printing Scheme, HTTP and CGI, Textual Conversion Packages +@section URI + +@include uri.txi + + + +@node Printing Scheme, Time and Date, URI, Textual Conversion Packages +@section Printing Scheme + +@menu +* Generic-Write:: 'generic-write +* Object-To-String:: 'object->string +* Pretty-Print:: 'pretty-print, 'pprint-file +@end menu + + +@node Generic-Write, Object-To-String, Printing Scheme, Printing Scheme +@subsection Generic-Write + +@code{(require 'generic-write)} +@ftindex 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. + +@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 Object-To-String, Pretty-Print, Generic-Write, Printing Scheme +@subsection Object-To-String + +@code{(require 'object->string)} +@ftindex object->string + +@include obj2str.txi + + +@node Pretty-Print, , Object-To-String, Printing Scheme +@subsection Pretty-Print + +@code{(require 'pretty-print)} +@ftindex 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 + +@deffn Procedure pretty-print->string obj +@deffnx Procedure pretty-print->string obj width + +Returns the string of @var{obj} @code{pretty-print}ed in @var{width} +columns. If @var{width} is not specified, @code{(output-port-width)} is +used. + +Example: +@example +@group +(pretty-print->string '((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))) +@result{} +"((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)) +" +@end group +@group +(pretty-print->string '((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)) + 16) +@result{} +"((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)) +" +@end group +@end example +@end deffn + + +@code{(require 'pprint-file)} +@ftindex 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)}. +@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}. +@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) +@ftindex pprint-file +(require 'defmacroexpand) +@ftindex defmacroexpand +(defmacro:load "my-macros.scm") +(pprint-filter-file "code.scm" defmacro:expand* "exp-code.scm") +@end lisp + +@node Time and Date, Vector Graphics, Printing Scheme, Textual Conversion Packages +@section Time and Date + +@menu +* Time Zone:: +* Posix Time:: 'posix-time +* Common-Lisp Time:: 'common-lisp-time +@end menu + +@noindent +If @code{(provided? 'current-time)}: + +@noindent +The procedures @code{current-time}, @code{difftime}, and +@code{offset-time} deal with a @dfn{calendar time} datatype +@cindex time +@cindex calendar time +which may or may not be disjoint from other Scheme datatypes. + +@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{Common-Lisp Time}. +@end defun + +@defun difftime caltime1 caltime0 +Returns the difference (number of seconds) between twe calendar times: +@var{caltime1} - @var{caltime0}. @var{caltime0} may 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 + +@node Time Zone, Posix Time, Time and Date, Time and Date +@subsection Time Zone + +(require 'time-zone) + +@deftp {Data Format} TZ-string + +POSIX standards specify several formats for encoding time-zone rules. + +@table @t +@item :@i{<pathname>} +If the first character of @i{<pathname>} is @samp{/}, then +@i{<pathname>} specifies the absolute pathname of a tzfile(5) format +time-zone file. Otherwise, @i{<pathname>} is interpreted as a pathname +within @var{tzfile:vicinity} (/usr/lib/zoneinfo/) naming a tzfile(5) +format time-zone file. +@item @i{<std>}@i{<offset>} +The string @i{<std>} consists of 3 or more alphabetic characters. +@i{<offset>} specifies the time difference from GMT. The @i{<offset>} +is positive if the local time zone is west of the Prime Meridian and +negative if it is east. @i{<offset>} can be the number of hours or +hours and minutes (and optionally seconds) separated by @samp{:}. For +example, @code{-4:30}. +@item @i{<std>}@i{<offset>}@i{<dst>} +@i{<dst>} is the at least 3 alphabetic characters naming the local +daylight-savings-time. +@item @i{<std>}@i{<offset>}@i{<dst>}@i{<doffset>} +@i{<doffset>} specifies the offset from the Prime Meridian when +daylight-savings-time is in effect. +@end table + +The non-tzfile formats can optionally be followed by transition times +specifying the day and time when a zone changes from standard to +daylight-savings and back again. + +@table @t +@item ,@i{<date>}/@i{<time>},@i{<date>}/@i{<time>} +The @i{<time>}s are specified like the @i{<offset>}s above, except that +leading @samp{+} and @samp{-} are not allowed. + +Each @i{<date>} has one of the formats: + +@table @t +@item J@i{<day>} +specifies the Julian day with @i{<day>} between 1 and 365. February 29 +is never counted and cannot be referenced. +@item @i{<day>} +This specifies the Julian day with n between 0 and 365. February 29 is +counted in leap years and can be specified. +@item M@i{<month>}.@i{<week>}.@i{<day>} +This specifies day @i{<day>} (0 <= @i{<day>} <= 6) of week @i{<week>} (1 +<= @i{<week>} <= 5) of month @i{<month>} (1 <= @i{<month>} <= 12). Week +1 is the first week in which day d occurs and week 5 is the last week in +which day @i{<day>} occurs. Day 0 is a Sunday. +@end table +@end table + +@end deftp + +@deftp {Data Type} time-zone +is a datatype encoding how many hours from Greenwich Mean Time the local +time is, and the @dfn{Daylight Savings Time} rules for changing it. +@end deftp + +@defun time-zone TZ-string +Creates and returns a time-zone object specified by the string +@var{TZ-string}. If @code{time-zone} cannot interpret @var{TZ-string}, +@code{#f} is returned. +@end defun + +@defun tz:params caltime tz +@var{tz} is a time-zone object. @code{tz:params} returns a list of +three items: +@enumerate 0 +@item +An integer. 0 if standard time is in effect for timezone @var{tz} at +@var{caltime}; 1 if daylight savings time is in effect for timezone +@var{tz} at @var{caltime}. +@item +The number of seconds west of the Prime Meridian timezone @var{tz} is at +@var{caltime}. +@item +The name for timezone @var{tz} at @var{caltime}. +@end enumerate + +@code{tz:params} is unaffected by the default timezone; inquiries can be +made of any timezone at any calendar time. + +@end defun + +@noindent +The rest of these procedures and variables are provided for POSIX +compatability. Because of shared state they are not thread-safe. + +@defun tzset +Returns the default time-zone. + +@defunx tzset tz +Sets (and returns) the default time-zone to @var{tz}. + +@defunx tzset TZ-string +Sets (and returns) the default time-zone to that specified by +@var{TZ-string}. + +@code{tzset} also sets the variables @var{*timezone*}, @var{daylight?}, +and @var{tzname}. This function is automatically called by the time +conversion procedures which depend on the time zone (@pxref{Time and +Date}). +@end defun + +@defvar *timezone* +Contains the difference, in seconds, between Greenwich Mean Time 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 + +@defvar daylight? +is @code{#t} if the default timezone has rules for @dfn{Daylight Savings +Time}. @emph{Note:} @var{daylight?} does not tell you when Daylight +Savings Time is in effect, just that the default zone sometimes has +Daylight Savings Time. +@end defvar + +@defvar tzname +is a vector of strings. Index 0 has the abbreviation for the standard +timezone; If @var{daylight?}, then index 1 has the abbreviation for the +Daylight Savings timezone. +@end defvar + + +@node Posix Time, Common-Lisp Time, Time Zone, Time and Date +@subsection Posix Time + +@example +(require 'posix-time) +@ftindex posix-time +@end example + +@deftp {Data Type} {Calendar-Time} +@cindex calendar time +@cindex caltime +is a datatype encapsulating time. +@end deftp + +@deftp {Data Type} {Coordinated Universal Time} +@cindex Coordinated Universal Time +@cindex UTC +(abbreviated @dfn{UTC}) is a vector of integers representing time: + +@enumerate 0 +@item + seconds (0 - 61) +@item + minutes (0 - 59) +@item + hours since midnight (0 - 23) +@item + day of month (1 - 31) +@item + month (0 - 11). Note difference from @code{decode-universal-time}. +@item + the number of years since 1900. Note difference from +@code{decode-universal-time}. +@item + day of week (0 - 6) +@item + day of year (0 - 365) +@item + 1 for daylight savings, 0 for regular time +@end enumerate +@end deftp + +@defun gmtime caltime +Converts the calendar time @var{caltime} to UTC and returns it. + +@defunx localtime caltime tz +Returns @var{caltime} converted to UTC relative to timezone @var{tz}. + +@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 +(@pxref{Time Zone,tzset}). + +@end defun + +@defun gmktime univtime +Converts a vector of integers in GMT Coordinated Universal Time (UTC) +format to a calendar time. + +@defunx mktime univtime +Converts a vector of integers in local Coordinated Universal Time (UTC) +format to a calendar time. + +@defunx mktime univtime tz +Converts a vector of integers in Coordinated Universal Time (UTC) format +(relative to time-zone @var{tz}) +to calendar time. +@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 gtime caltime +@defunx ctime caltime +@defunx ctime caltime tz +Equivalent to @code{(asctime (gmtime @var{caltime}))}, +@code{(asctime (localtime @var{caltime}))}, and +@code{(asctime (localtime @var{caltime} @var{tz}))}, respectively. +@end defun + + +@node Common-Lisp Time, , Posix Time, Time and Date +@subsection Common-Lisp Time + +@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.). Note difference from @code{gmtime} and @code{localtime}. +@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 Vector Graphics, Schmooz, Time and Date, Textual Conversion Packages +@section Vector Graphics + +@menu +* Tektronix Graphics Support:: +@end menu + +@node Tektronix Graphics Support, , Vector Graphics, Vector Graphics +@subsection Tektronix Graphics Support + +@emph{Note:} The Tektronix graphics support files need more work, and +are not complete. + +@subsubsection 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 + + +@subsubsection 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 Schmooz, , Vector Graphics, Textual Conversion Packages +@section Schmooz + +@include schmooz.texi + +@node Mathematical Packages, Database Packages, Textual Conversion Packages, Top +@chapter Mathematical Packages + +@menu +* Bit-Twiddling:: 'logical +* Modular Arithmetic:: 'modular +* Prime Numbers:: 'factor +* Random Numbers:: 'random +* Fast Fourier Transform:: 'fft +* Cyclic Checksum:: 'make-crc +* Plotting:: 'charplot +* Root Finding:: 'root +* Minimizing:: 'minimize +* Commutative Rings:: 'commutative-ring +* Determinant:: 'determinant +@end menu + + +@node Bit-Twiddling, Modular Arithmetic, Mathematical Packages, Mathematical Packages +@section Bit-Twiddling + +@code{(require 'logical)} +@ftindex 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 +@ftindex logical +functions. These functions behave as though operating on integers +in two's-complement representation. + +@subheading Bitwise Operations + +@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 bitwise-if mask n0 n1 +Returns an integer composed of some bits from integer @var{n0} and some +from integer @var{n1}. A bit of the result is taken from @var{n0} if the +corresponding bit of integer @var{mask} is 1 and from @var{n1} if that bit +of @var{mask} is 0. +@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 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 + + +@subheading Bit Within Word + +@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 copy-bit index from bit +Returns an integer the same as @var{from} except in the @var{index}th bit, +which is 1 if @var{bit} is @code{#t} and 0 if @var{bit} is @code{#f}. + +Example: +@example +(number->string (copy-bit 0 0 #t) 2) @result{} "1" +(number->string (copy-bit 2 0 #t) 2) @result{} "100" +(number->string (copy-bit 2 #b1111 #f) 2) @result{} "1011" +@end example +@end defun + +@subheading Fields of Bits + +@defun bit-field n start end +@findex bit-extract +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. + +This function was called @code{bit-extract} in previous versions of SLIB. +@refill + +Example: +@lisp +(number->string (bit-field #b1101101010 0 4) 2) + @result{} "1010" +(number->string (bit-field #b1101101010 4 9) 2) + @result{} "10110" +@end lisp +@end defun + +@defun copy-bit-field to start end from +Returns an integer the same as @var{to} except possibly in the +@var{start} (inclusive) through @var{end} (exclusive) bits, which are +the same as those of @var{from}. The 0-th bit of @var{from} becomes the +@var{start}th bit of the result. + +Example: +@example +(number->string (copy-bit-field #b1101101010 0 4 0) 2) + @result{} "1101100000" +(number->string (copy-bit-field #b1101101010 0 4 -1) 2) + @result{} "1101101111" +@end example +@end defun + +@defun ash int count +Returns an integer equivalent to +@code{(inexact->exact (floor (* @var{int} (expt 2 @var{count}))))}. + +Example: +@lisp +(number->string (ash #b1 3) 2) + @result{} "1000" +(number->string (ash #b1010 -1) 2) + @result{} "101" +@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 + +@node Modular Arithmetic, Prime Numbers, Bit-Twiddling, Mathematical Packages +@section Modular Arithmetic + +@code{(require 'modular)} +@ftindex 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. +@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 Numbers, Random Numbers, Modular Arithmetic, Mathematical Packages +@section Prime Numbers + +@code{(require 'factor)} +@ftindex factor +@ftindex primes + +@include factor.txi + + +@node Random Numbers, Fast Fourier Transform, Prime Numbers, Mathematical Packages +@section Random Numbers + +@code{(require 'random)} +@ftindex random + +@cindex RNG +@cindex PRNG +A pseudo-random number generator is only as good as the tests it passes. +George Marsaglia of Florida State University developed a battery of +tests named @dfn{DIEHARD} (@url{http://stat.fsu.edu/~geo/diehard.html}). +@file{diehard.c} has a bug which the patch +@url{http://swissnet.ai.mit.edu/ftpdir/users/jaffer/diehard.c.pat} corrects. + +SLIB's new PRNG generates 8 bits at a time. With the degenerate seed +@samp{0}, the numbers generated pass DIEHARD; but when bits are combined +from sequential bytes, tests fail. With the seed +@samp{http://swissnet.ai.mit.edu/~jaffer/SLIB.html}, all of those tests +pass. + +@include random.txi + + +If inexact numbers are supported by the Scheme implementation, +@file{randinex.scm} will be loaded as well. @file{randinex.scm} +contains procedures for generating inexact distributions. + +@include randinex.txi + + +@node Fast Fourier Transform, Cyclic Checksum, Random Numbers, Mathematical Packages +@section Fast Fourier Transform + +@code{(require 'fft)} +@ftindex fft + +@defun fft array +@var{array} is an array of @code{(expt 2 n)} numbers. @code{fft} +returns an array of complex numbers comprising the @dfn{Discrete Fourier +Transform} of @var{array}. + +@defunx fft-1 array +@code{fft-1} returns an array of complex numbers comprising the inverse +Discrete Fourier Transform of @var{array}. +@end defun + +@code{(fft-1 (fft @var{array}))} will return an array of values close to +@var{array}. + +@example +(fft '#(1 0+i -1 0-i 1 0+i -1 0-i)) @result{} + +#(0.0 0.0 0.0+628.0783185208527e-18i 0.0 + 0.0 0.0 8.0-628.0783185208527e-18i 0.0) + +(fft-1 '#(0 0 0 0 0 0 8 0)) @result{} + +#(1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i + 1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i) +@end example + + +@node Cyclic Checksum, Plotting, Fast Fourier Transform, Mathematical Packages +@section Cyclic Checksum + +@code{(require 'make-crc)} +@ftindex make-crc + +@defun make-port-crc +@defunx make-port-crc degree +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. + +@defunx make-port-crc generator + +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 value of @var{generator} must be larger than 127. + +@defunx make-port-crc degree generator + +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) +@ftindex 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{} 157103930 +@end example + +@node Plotting, Root Finding, Cyclic Checksum, Mathematical Packages +@section Plotting on Character Devices + +@code{(require 'charplot)} +@ftindex 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. +@ftindex charplot + +@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. + +Example: +@example +(require 'charplot) +@ftindex 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|- **** | + | ** ** | + 0.75|- * * | + | * * | + 0.5|- * * | + | * | + 0.25|- * | + | * * | + 0|-------------------*--------------------------| + | * | + -0.25|- * * | + | * * | + -0.5|- * | + | * * | + -0.75|- * * | + | ** ** | + -1|- **** | + |____________:_____._____:_____._____:_________| + x 2 4 6 +@end group +@end example +@end deffn + +@deffn Procedure plot-function! func x1 x2 +@deffnx Procedure plot-function! func x1 x2 npts +Plots the function of one argument @var{func} over the range @var{x1} to +@var{x2}. If the optional integer argument @var{npts} is supplied, it +specifies the number of points to evaluate @var{func} at. +@end deffn + + +@node Root Finding, Minimizing, Plotting, Mathematical Packages +@section Root Finding + +@code{(require 'root)} +@ftindex 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 @var{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 @var{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 @var{prec} is instead a negative integer, +@code{laguerre:find-polynomial-root} returns the result of -@var{prec} +iterations. +@end defun + +@defun secant:find-root f x0 x1 prec +@defunx secant:find-bracketed-root f x0 x1 prec +Given a real valued procedure @var{f} and two real valued starting +points @var{x0} and @var{x1}, returns a real @var{x} for which +@code{(abs (f x))} is less than @var{prec}; or returns +@code{#f} if such a real can't be found. + +If @var{x0} and @var{x1} are chosen such that they bracket a root, that is +@example +(or (< (f x0) 0 (f x1)) + (< (f x1) 0 (f x0))) +@end example +then the root returned will be between @var{x0} and @var{x1}, and +@var{f} will not be passed an argument outside of that interval. + +@code{secant:find-bracketed-root} will return @code{#f} unless @var{x0} +and @var{x1} bracket a root. + +The secant method is used until a bracketing interval is found, at which point +a modified @i{regula falsi} method is used. + +If @var{prec} is instead a negative integer, @code{secant:find-root} +returns the result of -@var{prec} iterations. + +If @var{prec} is a procedure it should accept 5 arguments: @var{x0} +@var{f0} @var{x1} @var{f1} and @var{count}, where @var{f0} will be +@code{(f x0)}, @var{f1} @code{(f x1)}, and @var{count} the number of +iterations performed so far. @var{prec} should return non-false +if the iteration should be stopped. +@end defun + +@node Minimizing, Commutative Rings, Root Finding, Mathematical Packages +@section Minimizing + +@code{(require 'minimize)} +@ftindex minimize +@cindex minimize + +@include minimize.txi + +@node Commutative Rings, Determinant, Minimizing, Mathematical Packages +@section Commutative Rings + +Scheme provides a consistent and capable set of numeric functions. +Inexacts implement a field; integers a commutative ring (and Euclidean +domain). This package allows one to use basic Scheme numeric functions +with symbols and non-numeric elements of commutative rings. + +@code{(require 'commutative-ring)} +@ftindex commutative-ring +@cindex ring, commutative + +The @dfn{commutative-ring} package makes the procedures @code{+}, +@code{-}, @code{*}, @code{/}, and @code{^} @dfn{careful} in the sense +@cindex careful +that any non-numeric arguments they do not reduce appear in the +expression output. In order to see what working with this package is +like, self-set all the single letter identifiers (to their corresponding +symbols). + +@example +(define a 'a) +@dots{} +(define z 'z) +@end example + +Or just @code{(require 'self-set)}. Now try some sample expressions: + +@example +(+ (+ a b) (- a b)) @result{} (* a 2) +(* (+ a b) (+ a b)) @result{} (^ (+ a b) 2) +(* (+ a b) (- a b)) @result{} (* (+ a b) (- a b)) +(* (- a b) (- a b)) @result{} (^ (- a b) 2) +(* (- a b) (+ a b)) @result{} (* (+ a b) (- a b)) +(/ (+ a b) (+ c d)) @result{} (/ (+ a b) (+ c d)) +(^ (+ a b) 3) @result{} (^ (+ a b) 3) +(^ (+ a 2) 3) @result{} (^ (+ 2 a) 3) +@end example + +Associative rules have been applied and repeated addition and +multiplication converted to multiplication and exponentiation. + +We can enable distributive rules, thus expanding to sum of products +form: +@example +(set! *ruleset* (combined-rulesets distribute* distribute/)) + +(* (+ a b) (+ a b)) @result{} (+ (* 2 a b) (^ a 2) (^ b 2)) +(* (+ a b) (- a b)) @result{} (- (^ a 2) (^ b 2)) +(* (- a b) (- a b)) @result{} (- (+ (^ a 2) (^ b 2)) (* 2 a b)) +(* (- a b) (+ a b)) @result{} (- (^ a 2) (^ b 2)) +(/ (+ a b) (+ c d)) @result{} (+ (/ a (+ c d)) (/ b (+ c d))) +(/ (+ a b) (- c d)) @result{} (+ (/ a (- c d)) (/ b (- c d))) +(/ (- a b) (- c d)) @result{} (- (/ a (- c d)) (/ b (- c d))) +(/ (- a b) (+ c d)) @result{} (- (/ a (+ c d)) (/ b (+ c d))) +(^ (+ a b) 3) @result{} (+ (* 3 a (^ b 2)) (* 3 b (^ a 2)) (^ a 3) (^ b 3)) +(^ (+ a 2) 3) @result{} (+ 8 (* a 12) (* (^ a 2) 6) (^ a 3)) +@end example + +Use of this package is not restricted to simple arithmetic expressions: + +@example +(require 'determinant) + +(determinant '((a b c) (d e f) (g h i))) @result{} +(- (+ (* a e i) (* b f g) (* c d h)) (* a f h) (* b d i) (* c e g)) +@end example + +Currently, only @code{+}, @code{-}, @code{*}, @code{/}, and @code{^} +support non-numeric elements. Expressions with @code{-} are converted +to equivalent expressions without @code{-}, so behavior for @code{-} is +not defined separately. @code{/} expressions are handled similarly. + +This list might be extended to include @code{quotient}, @code{modulo}, +@code{remainder}, @code{lcm}, and @code{gcd}; but these work only for +the more restrictive Euclidean (Unique Factorization) Domain. +@cindex Unique Factorization +@cindex Euclidean Domain + +@heading Rules and Rulesets + +The @dfn{commutative-ring} package allows control of ring properties +through the use of @dfn{rulesets}. + +@defvar *ruleset* +Contains the set of rules currently in effect. Rules defined by +@code{cring:define-rule} are stored within the value of *ruleset* at the +time @code{cring:define-rule} is called. If @var{*ruleset*} is +@code{#f}, then no rules apply. +@end defvar + +@defun make-ruleset rule1 @dots{} +@defunx make-ruleset name rule1 @dots{} +Returns a new ruleset containing the rules formed by applying +@code{cring:define-rule} to each 4-element list argument @var{rule}. If +the first argument to @code{make-ruleset} is a symbol, then the database +table created for the new ruleset will be named @var{name}. Calling +@code{make-ruleset} with no rule arguments creates an empty ruleset. +@end defun + +@defun combined-rulesets ruleset1 @dots{} +@defunx combined-rulesets name ruleset1 @dots{} +Returns a new ruleset containing the rules contained in each ruleset +argument @var{ruleset}. If the first argument to +@code{combined-ruleset} is a symbol, then the database table created for +the new ruleset will be named @var{name}. Calling +@code{combined-ruleset} with no ruleset arguments creates an empty +ruleset. +@end defun + +Two rulesets are defined by this package. + +@defvr Constant distribute* +Contain the ruleset to distribute multiplication over addition and +subtraction. +@defvrx Constant distribute/ +Contain the ruleset to distribute division over addition and +subtraction. + +Take care when using both @var{distribute*} and @var{distribute/} +simultaneously. It is possible to put @code{/} into an infinite loop. +@end defvr + +You can specify how sum and product expressions containing non-numeric +elements simplify by specifying the rules for @code{+} or @code{*} for +cases where expressions involving objects reduce to numbers or to +expressions involving different non-numeric elements. + +@defun cring:define-rule op sub-op1 sub-op2 reduction +Defines a rule for the case when the operation represented by symbol +@var{op} is applied to lists whose @code{car}s are @var{sub-op1} and +@var{sub-op2}, respectively. The argument @var{reduction} is a +procedure accepting 2 arguments which will be lists whose @code{car}s +are @var{sub-op1} and @var{sub-op2}. + +@defunx cring:define-rule op sub-op1 'identity reduction +Defines a rule for the case when the operation represented by symbol +@var{op} is applied to a list whose @code{car} is @var{sub-op1}, and +some other argument. @var{Reduction} will be called with the list whose +@code{car} is @var{sub-op1} and some other argument. + +If @var{reduction} returns @code{#f}, the reduction has failed and other +reductions will be tried. If @var{reduction} returns a non-false value, +that value will replace the two arguments in arithmetic (@code{+}, +@code{-}, and @code{*}) calculations involving non-numeric elements. + +The operations @code{+} and @code{*} are assumed commutative; hence both +orders of arguments to @var{reduction} will be tried if necessary. + +The following rule is the definition for distributing @code{*} over +@code{+}. + +@example +(cring:define-rule + '* '+ 'identity + (lambda (exp1 exp2) + (apply + (map (lambda (trm) (* trm exp2)) (cdr exp1)))))) +@end example +@end defun + +@heading How to Create a Commutative Ring + +The first step in creating your commutative ring is to write procedures +to create elements of the ring. A non-numeric element of the ring must +be represented as a list whose first element is a symbol or string. +This first element identifies the type of the object. A convenient and +clear convention is to make the type-identifying element be the same +symbol whose top-level value is the procedure to create it. + +@example +(define (n . list1) + (cond ((and (= 2 (length list1)) + (eq? (car list1) (cadr list1))) + 0) + ((not (term< (first list1) (last1 list1))) + (apply n (reverse list1))) + (else (cons 'n list1)))) + +(define (s x y) (n x y)) + +(define (m . list1) + (cond ((neq? (first list1) (term_min list1)) + (apply m (cyclicrotate list1))) + ((term< (last1 list1) (cadr list1)) + (apply m (reverse (cyclicrotate list1)))) + (else (cons 'm list1)))) +@end example + +Define a procedure to multiply 2 non-numeric elements of the ring. +Other multiplicatons are handled automatically. Objects for which rules +have @emph{not} been defined are not changed. + +@example +(define (n*n ni nj) + (let ((list1 (cdr ni)) (list2 (cdr nj))) + (cond ((null? (intersection list1 list2)) #f) + ((and (eq? (last1 list1) (first list2)) + (neq? (first list1) (last1 list2))) + (apply n (splice list1 list2))) + ((and (eq? (first list1) (first list2)) + (neq? (last1 list1) (last1 list2))) + (apply n (splice (reverse list1) list2))) + ((and (eq? (last1 list1) (last1 list2)) + (neq? (first list1) (first list2))) + (apply n (splice list1 (reverse list2)))) + ((and (eq? (last1 list1) (first list2)) + (eq? (first list1) (last1 list2))) + (apply m (cyclicsplice list1 list2))) + ((and (eq? (first list1) (first list2)) + (eq? (last1 list1) (last1 list2))) + (apply m (cyclicsplice (reverse list1) list2))) + (else #f)))) +@end example + +Test the procedures to see if they work. + +@example +;;; where cyclicrotate(list) is cyclic rotation of the list one step +;;; by putting the first element at the end +(define (cyclicrotate list1) + (append (rest list1) (list (first list1)))) +;;; and where term_min(list) is the element of the list which is +;;; first in the term ordering. +(define (term_min list1) + (car (sort list1 term<))) +(define (term< sym1 sym2) + (string<? (symbol->string sym1) (symbol->string sym2))) +(define first car) +(define rest cdr) +(define (last1 list1) (car (last-pair list1))) +(define (neq? obj1 obj2) (not (eq? obj1 obj2))) +;;; where splice is the concatenation of list1 and list2 except that their +;;; common element is not repeated. +(define (splice list1 list2) + (cond ((eq? (last1 list1) (first list2)) + (append list1 (cdr list2))) + (else (error 'splice list1 list2)))) +;;; where cyclicsplice is the result of leaving off the last element of +;;; splice(list1,list2). +(define (cyclicsplice list1 list2) + (cond ((and (eq? (last1 list1) (first list2)) + (eq? (first list1) (last1 list2))) + (butlast (splice list1 list2) 1)) + (else (error 'cyclicsplice list1 list2)))) + +(N*N (S a b) (S a b)) @result{} (m a b) +@end example + +Then register the rule for multiplying type N objects by type N objects. + +@example +(cring:define-rule '* 'N 'N N*N)) +@end example + +Now we are ready to compute! + +@example +(define (t) + (define detM + (+ (* (S g b) + (+ (* (S f d) + (- (* (S a f) (S d g)) (* (S a g) (S d f)))) + (* (S f f) + (- (* (S a g) (S d d)) (* (S a d) (S d g)))) + (* (S f g) + (- (* (S a d) (S d f)) (* (S a f) (S d d)))))) + (* (S g d) + (+ (* (S f b) + (- (* (S a g) (S d f)) (* (S a f) (S d g)))) + (* (S f f) + (- (* (S a b) (S d g)) (* (S a g) (S d b)))) + (* (S f g) + (- (* (S a f) (S d b)) (* (S a b) (S d f)))))) + (* (S g f) + (+ (* (S f b) + (- (* (S a d) (S d g)) (* (S a g) (S d d)))) + (* (S f d) + (- (* (S a g) (S d b)) (* (S a b) (S d g)))) + (* (S f g) + (- (* (S a b) (S d d)) (* (S a d) (S d b)))))) + (* (S g g) + (+ (* (S f b) + (- (* (S a f) (S d d)) (* (S a d) (S d f)))) + (* (S f d) + (- (* (S a b) (S d f)) (* (S a f) (S d b)))) + (* (S f f) + (- (* (S a d) (S d b)) (* (S a b) (S d d)))))))) + (* (S b e) (S c a) (S e c) + detM + )) +(pretty-print (t)) +@print{} +(- (+ (m a c e b d f g) + (m a c e b d g f) + (m a c e b f d g) + (m a c e b f g d) + (m a c e b g d f) + (m a c e b g f d)) + (* 2 (m a b e c) (m d f g)) + (* (m a c e b d) (m f g)) + (* (m a c e b f) (m d g)) + (* (m a c e b g) (m d f))) +@end example + +@node Determinant, , Commutative Rings, Mathematical Packages +@section Determinant + +@defun determinant square-matrix +Returns the determinant of @var{square-matrix}. + +@example +(require 'determinant) +(determinant '((1 2) (3 4))) @result{} -2 +(determinant '((1 2 3) (4 5 6) (7 8 9))) @result{} 0 +(determinant '((1 2 3 4) (5 6 7 8) (9 10 11 12))) @result{} 0 +@end example +@end defun + + +@node Database Packages, Other Packages, Mathematical Packages, Top +@chapter Database Packages + +@menu +* Base Table:: +* Relational Database:: 'relational-database +* Weight-Balanced Trees:: 'wt-tree +@end menu + +@node Base Table, Relational Database, Database Packages, Database Packages +@section Base Table + +A base table implementation using Scheme association lists is available +as the value of the identifier @code{alist-table} after doing: + +@code{(require 'alist-table)} +@ftindex 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 @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) +@ftindex 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. + +@noindent +@cindex match-keys +@cindex match +@cindex wild-card +In contrast, a @var{match-keys} argument is a list of length equal to +the number of primary keys. The @var{match-keys} restrict the actions +of the table command to those records whose primary keys all satisfy the +corresponding element of the @var{match-keys} list. The elements and +their actions are: + +@quotation +@table @asis +@item @code{#f} +The false value matches any key in the corresponding position. +@item an object of type procedure +This procedure must take a single argument, the key in the corresponding +position. Any key for which the procedure returns a non-false value is +a match; Any key for which the procedure returns a @code{#f} is not. +@item other values +Any other value matches only those keys @code{equal?} to it. +@end table +@end quotation + +@noindent +The @var{key-dimension} and @var{column-types} arguments are needed to +decode the combined-keys for matching with @var{match-keys}. + +@defun for-each-key handle procedure key-dimension column-types match-keys +Calls @var{procedure} once with each @var{key} in the table opened in +@var{handle} which satisfy @var{match-keys} in an unspecified order. +An unspecified value is returned. +@end defun + +@defun map-key handle procedure key-dimension column-types match-keys +Returns a list of the values returned by calling @var{procedure} once +with each @var{key} in the table opened in @var{handle} which satisfy +@var{match-keys} in an unspecified order. +@end defun + +@defun ordered-for-each-key handle procedure key-dimension column-types match-keys +Calls @var{procedure} once with each @var{key} in the table opened in +@var{handle} which satisfy @var{match-keys} in the natural order for +the types of the primary key fields of that table. An unspecified value +is returned. +@end defun + +@defun delete* handle key-dimension column-types match-keys +Removes all rows which satisfy @var{match-keys} from the table opened in +@var{handle}. 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, Database Packages +@section Relational Database + +@code{(require 'relational-database)} +@ftindex 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 +* Database Reports:: +* Database Browser:: 'database-browse +@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 conscientious 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) +@ftindex 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, +@ref{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 sync-database +Causes any pending updates to the database file to be written out. 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 +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 must not +be missing. + +@defun get column-name +Returns a procedure of arguments @var{key1} @var{key2} @dots{} which +returns the value for the @var{column-name} column of the row associated +with primary keys @var{key1}, @var{key2} @dots{} if that row exists in +the table, or @code{#f} otherwise. + +@example +((plat 'get 'processor) 'djgpp) @result{} i386 +((plat 'get 'processor) 'be-os) @result{} #f +@end example + +@defunx get* column-name +Returns a procedure of optional arguments @var{match-key1} @dots{} which +returns a list of the values for the specified column for all rows in +this table. The optional @var{match-key1} @dots{} arguments restrict +actions to a subset of the table. See the match-key description below +for details. + +@example +((plat 'get* 'processor)) @result{} +(i386 8086 i386 8086 i386 i386 8086 m68000 + m68000 m68000 m68000 m68000 powerpc) + +((plat 'get* 'processor) #f) @result{} +(i386 8086 i386 8086 i386 i386 8086 m68000 + m68000 m68000 m68000 m68000 powerpc) + +(define (a-key? key) + (char=? #\a (string-ref (symbol->string key) 0))) + +((plat 'get* 'processor) a-key?) @result{} +(m68000 m68000 m68000 m68000 m68000 powerpc) + +((plat 'get* 'name) a-key?) @result{} +(atari-st-turbo-c atari-st-gcc amiga-sas/c-5.10 + amiga-aztec amiga-dice-c aix) +@end example +@end defun + +@defun row:retrieve +Returns a procedure of arguments @var{key1} @var{key2} @dots{} which +returns the row associated with primary keys @var{key1}, @var{key2} +@dots{} if it exists, or @code{#f} otherwise. + +@example +((plat 'row:retrieve) 'linux) @result{} (linux i386 linux gcc) +((plat 'row:retrieve) 'multics) @result{} #f +@end example + +@defunx row:retrieve* +Returns a procedure of optional arguments @var{match-key1} @dots{} which +returns a list of all rows in this table. The optional @var{match-key1} +@dots{} arguments restrict actions to a subset of the table. See the +match-key description below for details. +@end defun + +@example +((plat 'row:retrieve*) a-key?) @result{} +((atari-st-turbo-c m68000 atari turbo-c) + (atari-st-gcc m68000 atari gcc) + (amiga-sas/c-5.10 m68000 amiga sas/c) + (amiga-aztec m68000 amiga aztec) + (amiga-dice-c m68000 amiga dice-c) + (aix powerpc aix -)) +@end example + +@defun row:remove +Returns a procedure of arguments @var{key1} @var{key2} @dots{} which +removes and returns the row associated with primary keys @var{key1}, +@var{key2} @dots{} if it exists, or @code{#f} otherwise. + +@defunx row:remove* +Returns a procedure of optional arguments @var{match-key1} @dots{} which +removes and returns a list of all rows in this table. The optional +@var{match-key1} @dots{} arguments restrict actions to a subset of the +table. See the match-key description below for details. +@end defun + +@defun row:delete +Returns a procedure of arguments @var{key1} @var{key2} @dots{} which +deletes the row associated with primary keys @var{key1}, @var{key2} +@dots{} if it exists. The value returned is unspecified. + +@defunx row:delete* +Returns a procedure of optional arguments @var{match-key1} @dots{} which +Deletes all rows from this table. The optional @var{match-key1} @dots{} +arguments restrict deletions to a subset of the table. See the +match-key description below for details. The value returned is +unspecified. The descriptor table and catalog entry for this table are +not affected. +@end defun + +@defun row:update +Returns a procedure of one argument, @var{row}, which 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* +Returns a procedure of one argument, @var{rows}, which adds each row in +the list of rows, @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 +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* +Returns a procedure of one argument, @var{rows}, which adds each row in +the list of rows, @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 +Returns a procedure of arguments @var{proc} @var{match-key1} @dots{} +which calls @var{proc} with each @var{row} in this table in the +(implementation-dependent) natural ordering for rows. The optional +@var{match-key1} @dots{} arguments restrict actions to a subset of the +table. See the match-key description below for details. + +@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 + +@noindent +@cindex match-keys +The (optional) @var{match-key1} @dots{} arguments are used to restrict +actions of a whole-table operation to a subset of that table. Those +procedures (returned by methods) which accept match-key arguments will +accept any number of match-key arguments between zero and the number of +primary keys in the table. Any unspecified @var{match-key} arguments +default to @code{#f}. + +@noindent +The @var{match-key1} @dots{} restrict the actions of the table command +to those records whose primary keys each satisfy the corresponding +@var{match-key} argument. The arguments and their actions are: + +@quotation +@table @asis +@item @code{#f} +The false value matches any key in the corresponding position. +@item an object of type procedure +This procedure must take a single argument, the key in the corresponding +position. Any key for which the procedure returns a non-false value is +a match; Any key for which the procedure returns a @code{#f} is not. +@item other values +Any other value matches only those keys @code{equal?} to it. +@end table +@end quotation + +@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; thus they would +require locks in order to operate properly in a multiprocess +environment. Are all examples of utilities whose state should not be +part of transactions also non-reentrant? If so, perhaps suspending +transaction capture for the duration of locks would solve this problem. +@end table + +@node Database Utilities, Database Reports, Unresolved Issues, Relational Database +@subsection Database Utilities + +@code{(require 'database-utilities)} +@ftindex 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 + defaulter expression + expander 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{defaulter} field is an expression whose value is either +@code{#f} or a procedure of one argument (the parameter-list) which +returns a @emph{list} of the default value or values as appropriate. +Note that since the @code{defaulter} 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 types +A list of the type name of each parameter. Correspnds to the +@code{type-id} field of the contents of the @code{domain} of the +@var{command}'s parameter-table. +@item defaulters +A list of the defaulters for each parameter. Corresponds to +the @code{defaulters} 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) +@ftindex database-utilities +(require 'fluid-let) +@ftindex fluid-let +(require 'parameters) +@ftindex parameters +(require 'getopt) +@ftindex getopt + +(define my-rdb (create-database #f 'alist-table)) + +(define-tables my-rdb + '(foo-params + *parameter-columns* + *parameter-columns* + ((1 single-string single string + (lambda (pl) '("str")) #f "single string") + (2 nary-symbols nary symbol + (lambda (pl) '()) #f "zero or more symbols") + (3 nary1-symbols nary1 symbol + (lambda (pl) '(symb)) #f "one or more symbols") + (4 optional-number optional uint + (lambda (pl) '()) #f "zero or one number") + (5 flag boolean boolean + (lambda (pl) '(#f)) #f "a boolean flag"))) + '(foo-pnames + ((name string)) + ((parameter-index uint)) + (("s" 1) + ("single-string" 1) + ("n" 2) + ("nary-symbols" 2) + ("N" 3) + ("nary1-symbols" 3) + ("o" 4) + ("optional-number" 4) + ("f" 5) + ("flag" 5))) + '(my-commands + ((name symbol)) + ((parameters parameter-list) + (parameter-names parameter-name-translation) + (procedure expression) + (documentation string)) + ((foo + foo-params + foo-pnames + (lambda (rdb) (lambda args (print args))) + "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 defaulters dirs aliases) + (apply comval (getopt->arglist + argc argv options positions + arities types defaulters dirs aliases))))) + +(define (cmd . opts) + (fluid-let ((*optind* 1)) + (printf "%-34s @result{} " + (call-with-output-string + (lambda (pt) (write (cons 'cmd opts) pt)))) + (set! opts (cons "cmd" opts)) + (force-output) + (dbutil:serve-command-line + my-rdb 'my-commands 'foo (length opts) opts))) + +(cmd) @result{} ("str" () (symb) () #f) +(cmd "-f") @result{} ("str" () (symb) () #t) +(cmd "--flag") @result{} ("str" () (symb) () #t) +(cmd "-o177") @result{} ("str" () (symb) (177) #f) +(cmd "-o" "177") @result{} ("str" () (symb) (177) #f) +(cmd "--optional" "621") @result{} ("str" () (symb) (621) #f) +(cmd "--optional=621") @result{} ("str" () (symb) (621) #f) +(cmd "-s" "speciality") @result{} ("speciality" () (symb) () #f) +(cmd "-sspeciality") @result{} ("speciality" () (symb) () #f) +(cmd "--single" "serendipity") @result{} ("serendipity" () (symb) () #f) +(cmd "--single=serendipity") @result{} ("serendipity" () (symb) () #f) +(cmd "-n" "gravity" "piety") @result{} ("str" () (piety gravity) () #f) +(cmd "-ngravity" "piety") @result{} ("str" () (piety gravity) () #f) +(cmd "--nary" "chastity") @result{} ("str" () (chastity) () #f) +(cmd "--nary=chastity" "") @result{} ("str" () ( chastity) () #f) +(cmd "-N" "calamity") @result{} ("str" () (calamity) () #f) +(cmd "-Ncalamity") @result{} ("str" () (calamity) () #f) +(cmd "--nary1" "surety") @result{} ("str" () (surety) () #f) +(cmd "--nary1=surety") @result{} ("str" () (surety) () #f) +(cmd "-N" "levity" "fealty") @result{} ("str" () (fealty levity) () #f) +(cmd "-Nlevity" "fealty") @result{} ("str" () (fealty levity) () #f) +(cmd "--nary1" "surety" "brevity") @result{} ("str" () (brevity surety) () #f) +(cmd "--nary1=surety" "brevity") @result{} ("str" () (brevity surety) () #f) +(cmd "-?") +@print{} +Usage: cmd [OPTION ARGUMENT ...] ... + + -f, --flag + -o, --optional[=]<number> + -n, --nary[=]<symbols> ... + -N, --nary1[=]<symbols> ... + -s, --single[=]<string> + +ERROR: getopt->parameter-list "unrecognized option" "-?" +@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}. Currently, these fields are +@itemize @bullet +@item +domain-name +@item +foreign-table +@item +domain-integrity-rule +@item +type-id +@item +type-param +@end itemize + +The following example adds 3 domains to the @samp{build} database. +@samp{Optstring} is either a string or @code{#f}. @code{filename} is a +string and @code{build-whats} is a symbol. + +@example +(for-each (build 'add-domain) + '((optstring #f + (lambda (x) (or (not x) (string? x))) + string + #f) + (filename #f #f string #f) + (build-whats #f #f symbol #f))) +@end example +@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 + +@subsubheading 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 (which returns @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 + + +@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) +@ftindex 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 + +@subsubheading Listing Tables + +@deffn Procedure list-table-definition rdb table-name +If symbol @var{table-name} exists in the open relational-database +@var{rdb}, then returns a list of the table-name, its primary key names +and domains, its other key names and domains, and the table's records +(as lists). Otherwise, returns #f. + +The list returned by @code{list-table-definition}, when passed as an +argument to @code{define-tables}, will recreate the table. +@end deffn + + +@node Database Reports, Database Browser, Database Utilities, Relational Database +@subsection Database Reports + +@noindent +Code for generating database reports is in @file{report.scm}. After +writing it using @code{format}, I discovered that Common-Lisp +@code{format} is not useable for this application because there is no +mechanismm for truncating fields. @file{report.scm} needs to be +rewritten using @code{printf}. + +@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 + +The report is prepared as follows: + +@itemize @bullet +@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 + +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 + + + +@node Database Browser, , Database Reports, Relational Database +@subsection Database Browser + +(require 'database-browse) + +@deffn Procedure browse database + +Prints the names of all the tables in @var{database} and sets browse's +default to @var{database}. + +@deffnx Procedure browse + +Prints the names of all the tables in the default database. + +@deffnx Procedure browse table-name + +For each record of the table named by the symbol @var{table-name}, +prints a line composed of all the field values. + +@deffnx Procedure browse pathname + +Opens the database named by the string @var{pathname}, prints the names +of all its tables, and sets browse's default to the database. + +@deffnx Procedure browse database table-name + +Sets browse's default to @var{database} and prints the records of the +table named by the symbol @var{table-name}. + +@deffnx Procedure browse pathname table-name + +Opens the database named by the string @var{pathname} and sets browse's +default to it; @code{browse} prints the records of the table named by +the symbol @var{table-name}. + +@end deffn + +@node Weight-Balanced Trees, , Relational Database, Database Packages +@section Weight-Balanced Trees + +@code{(require 'wt-tree)} +@ftindex 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 Other Packages, About SLIB, Database Packages, Top +@chapter Other Packages + +@menu +* Data Structures:: Various data structures. +* Procedures:: Miscellaneous utility procedures. +* Standards Support:: Support for Scheme Standards. +* Session Support:: REPL and Debugging. +* Extra-SLIB Packages:: +@end menu + + +@node Data Structures, Procedures, Other Packages, Other Packages +@section Data Structures + + + +@menu +* Arrays:: 'array +* Array Mapping:: 'array-for-each +* Association Lists:: 'alist +* Byte:: 'byte +* Portable Image Files:: 'pnm +* Collections:: 'collect +* Dynamic Data Type:: 'dynamic +* Hash Tables:: 'hash-table +* Hashing:: 'hash, 'sierpinski, 'soundex +* Object:: 'object +* Priority Queues:: 'priority-queue +* Queues:: 'queue +* Records:: 'record +* Structures:: 'struct, 'structure +@end menu + + + + +@node Arrays, Array Mapping, Data Structures, Data Structures +@subsection Arrays + +@code{(require 'array)} +@ftindex 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}. +@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}. +@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 index1 index2 +@defunx array-3d-ref array index1 index2 index3 +@end defun + +@deffn Procedure array-1d-set! array new-value index +@deffnx Procedure array-2d-set! array new-value index1 index2 +@deffnx Procedure array-3d-set! array new-value index1 index2 index3 +@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. + +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 +@subsection Array Mapping + +@code{(require 'array-for-each)} +@ftindex 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-index-map! array proc +applies @var{proc} to the indices of each element of @var{array} in +turn, storing the result in the corresponding element. The value +returned and the order of application are unspecified. + +One can implement @var{array-indexes} as +@example +(define (array-indexes array) + (let ((ra (apply make-array #f (array-shape array)))) + (array-index-map! ra (lambda x x)) + ra)) +@end example +Another example: +@example +(define (apl:index-generator n) + (let ((v (make-uniform-vector n 1))) + (array-index-map! v (lambda (i) i)) + v)) +@end example +@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, Byte, Array Mapping, Data Structures +@subsection Association Lists + +@code{(require 'alist)} +@ftindex 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. + +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. +@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}. +@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 Byte, Portable Image Files, Association Lists, Data Structures +@subsection Byte + +@code{(require 'byte)} + +Some algorithms are expressed in terms of arrays of small integers. +Using Scheme strings to implement these arrays is not portable vis-a-vis +the correspondence between integers and characters and non-ascii +character sets. These functions abstract the notion of a @dfn{byte}. +@cindex byte + +@deffn Function byte-ref bytes k +@var{k} must be a valid index of @var{bytes}. @code{byte-ref} returns +byte @var{k} of @var{bytes} using zero-origin indexing. +@findex byte-ref +@end deffn + +@deffn Procedure byte-set! bytes k byte +@var{k} must be a valid index of @var{bytes}%, and @var{byte} must be a +small integer. @code{Byte-set!} stores @var{byte} in element @var{k} +of @var{bytes} +@findex byte-set! +and returns an unspecified value. @c <!> + +@end deffn + +@deffn Function make-bytes k +@deffnx Function make-bytes k byte + +@code{Make-bytes} returns a newly allocated byte-array of +@findex make-bytes +length @var{k}. If @var{byte} is given, then all elements of the +byte-array are initialized to @var{byte}, otherwise the contents of the +byte-array are unspecified. + +@end deffn + +@deffn Function bytes-length bytes + +@code{bytes-length} returns length of byte-array @var{bytes}. +@findex bytes-length + +@end deffn + +@deffn Function write-byte byte +@deffnx Function write-byte byte port + +Writes the byte @var{byte} (not an external representation of the +byte) to the given @var{port} 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}. +@findex current-output-port + +@end deffn + +@deffn Function read-byte +@deffnx Function read-byte port + +Returns the next byte available from the input @var{port}, updating +the @var{port} to point to the following byte. If no more bytes +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}. +@findex current-input-port + +@end deffn + +@deffn Function bytes byte @dots{} + +Returns a newly allocated byte-array composed of the arguments. + +@end deffn + +@deffn Function bytes->list bytes +@deffnx Function list->bytes bytes + +@code{Bytes->list} returns a newly allocated list of the +@findex bytes->list +bytes that make up the given byte-array. @code{List->bytes} +@findex list->bytes +returns a newly allocated byte-array formed from the small integers in +the list @var{bytes}. @code{Bytes->list} and @code{list->bytes} are +@findex list->bytes +@findex bytes->list +inverses so far as @code{equal?} is concerned. +@findex equal? + +@end deffn + +@node Portable Image Files, Collections, Byte, Data Structures +@subsection Portable Image Files + +@code{(require 'pnm)} + +@deffn Function pnm:type-dimensions path +The string @var{path} must name a @dfn{portable bitmap graphics} file. +@code{pnm:type-dimensions} returns a list of 4 items: +@enumerate +@item +A symbol describing the type of the file named by @var{path}. +@item +The image width in pixels. +@item +The image height in pixels. +@item +The maximum value of pixels assume in the file. +@end enumerate + +The current set of file-type symbols is: +@table @asis +@item pbm +@itemx pbm-raw +Black-and-White image; pixel values are 0 or 1. +@item pgm +@itemx pgm-raw +Gray (monochrome) image; pixel values are from 0 to @var{maxval} +specified in file header. +@item ppm +@itemx ppm-raw +RGB (full color) image; red, green, and blue interleaved pixel values +are from 0 to @var{maxval} +@end table + +@end deffn + +@deffn Function pnm:image-file->array path array + +Reads the @dfn{portable bitmap graphics} file named by @var{path} into +@var{array}. @var{array} must be the correct size and type for +@var{path}. @var{array} is returned. + +@deffnx Function pnm:image-file->array path + +@code{pnm:image-file->array} creates and returns an array with the +@dfn{portable bitmap graphics} file named by @var{path} read into it. + +@end deffn + +@deffn Procedure pnm:array-write type array maxval path + +Writes the contents of @var{array} to a @var{type} image file named +@var{path}. The file will have pixel values between 0 and @var{maxval}, +which must be compatible with @var{type}. For @samp{pbm} files, +@var{maxval} must be @samp{1}. + +@end deffn + + +@node Collections, Dynamic Data Type, Portable Image Files, Data Structures +@subsection 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)} +@ftindex 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). + +New types of collections may be defined as YASOS objects (@pxref{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. + +@defun collection? obj +A predicate, true initially of lists, vectors and strings. New sorts of +collections must answer @code{#t} to @code{collection?}. +@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}. + +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. + +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} +(@pxref{Lists as sequences}) to collections which will shadow the +list-based version if @code{(require 'collect)} follows +@ftindex collect +@code{(require 'common-list-functions)} (@pxref{Common List +Functions}). +@ftindex common-list-functions + +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} (@pxref{Lists as +sequences}) to collections. + +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} (@pxref{Lists as +sequences}) to collections. + +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 @ref{Setters} for a definition of @dfn{setter}. N.B. +@code{(setter list-ref)} doesn't work properly for element 0 of a +list. +@end defun + +Here is a sample collection: @code{simple-table} which is also a +@code{table}. +@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 +@subsection Dynamic Data Type + +@code{(require 'dynamic)} +@ftindex 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. +@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. +@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. +@end defun + +The @code{dynamic-bind} macro is not implemented. + + + + +@node Hash Tables, Hashing, Dynamic Data Type, Data Structures +@subsection Hash Tables + +@code{(require 'hash-table)} +@ftindex 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=?}. +@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=?}. + +@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. +@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}. +@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. +@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. +@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, Object, Hash Tables, Data Structures +@subsection Hashing + +@code{(require 'hash)} +@ftindex 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. + +For @code{hashq}, @code{(eq? obj1 obj2)} implies @code{(= (hashq obj1 k) +(hashq obj2))}. + +For @code{hashv}, @code{(eqv? obj1 obj2)} implies @code{(= (hashv obj1 k) +(hashv obj2))}. + +For @code{hash}, @code{(equal? obj1 obj2)} implies @code{(= (hash obj1 k) +(hash obj2))}. + +@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}. +@end defun + + +@code{(require 'sierpinski)} +@ftindex 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: +@itemize @bullet + +@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 itemize +@end defun + + + +@code{(require 'soundex)} +@ftindex 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 languages. + +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 Object, Priority Queues, Hashing, Data Structures +@subsection Macroless Object System +@include objdoc.txi + + +@node Priority Queues, Queues, Object, Data Structures +@subsection Priority Queues + +@code{(require 'priority-queue)} +@ftindex 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}. +@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. +@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. +@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 +@subsection Queues + +@code{(require 'queue)} +@ftindex 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. + +@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. + +@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. +@end deffn + + + + + +@node Records, Structures, Queues, Data Structures +@subsection Records + +@code{(require 'record)} +@ftindex 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. +@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. +@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}. +@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. +@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. +@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. +@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}. +@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}. +@end defun + +In May of 1996, as a product of discussion on the @code{rrrs-authors} +mailing list, I rewrote @file{record.scm} to portably implement type +disjointness for record data types. + +As long as an implementation's procedures are opaque and the +@code{record} code is loaded before other programs, this will give +disjoint record types which are unforgeable and incorruptible by R4RS +procedures. + +As a consequence, the procedures @code{record?}, +@code{record-type-descriptor}, @code{record-type-name}.and +@code{record-type-field-names} are no longer supported. + +@ignore +@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. +@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. +@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}. +@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}. +@end defun +@end ignore + + +@node Structures, , Records, Data Structures +@subsection Structures + +@code{(require 'struct)} (uses defmacros) +@ftindex struct + +@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{tag}-var1! obj val +@end defun +@defun set-@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 Procedures, Standards Support, Data Structures, Other Packages +@section Procedures + +Anything that doesn't fall neatly into any of the other categories winds +up here. + +@menu +* Common List Functions:: 'common-list-functions +* Tree Operations:: 'tree +* Type Coercion:: 'coerce +* Chapter Ordering:: 'chapter-order +* Sorting:: 'sort +* Topological Sort:: Keep your socks on. +* String-Case:: 'string-case +* String Ports:: 'string-port +* String Search:: Also Search from a Port. +* Line I/O:: 'line-i/o +* Multi-Processing:: 'process +* Metric Units:: Portable manifest types for numeric values. +@end menu + + +@node Common List Functions, Tree Operations, Procedures, Procedures +@subsection Common List Functions + +@code{(require 'common-list-functions)} +@ftindex 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 +@subsubsection 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}. + +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. + +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 +@subsubsection Lists as sets + +@code{eqv?} is used to test for membership by procedures which treat +lists as sets. + +@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})}. + +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. + +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}. + +Example: +@lisp +(intersection '(1 2 3 4) '(3 4 5 6)) + @result{} (4 3) +(intersection '(1 2 3 4) '(5 6 7 8)) + @result{} () +@end lisp +@end defun + +@defun set-difference l1 l2 +@code{set-difference} returns all elements that are in @var{l1} but not +in @var{l2}. + +Example: +@lisp +(set-difference '(1 2 3 4) '(3 4 5 6)) + @result{} (2 1) +(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}. + +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. + + +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. + +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. +@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. + +Example: +@lisp +(notevery even? '(1 2 3 4)) + @result{} #t + +(notevery even? '(2 4 6 8)) + @result{} #f +@end lisp +@end defun + + +@defun list-of?? predicate +Returns a predicate which returns true if its argument is a list every +element of which satisfies @var{predicate}. + +@defunx list-of?? predicate low-bound high-bound +@var{low-bound} and @var{high-bound} are non-negative integers. +@code{list-of??} returns a predicate which returns true if its argument +is a list of length between @var{low-bound} and @var{high-bound} +(inclusive); every element of which satisfies @var{predicate}. + +@defunx list-of?? predicate bound +@var{bound} is an integer. If @var{bound} is negative, @code{list-of??} +returns a predicate which returns true if its argument is a list of +length greater than @code{(- @var{bound})}; every element of which +satisfies @var{predicate}. Otherwise, @code{list-of??} returns a +predicate which returns true if its argument is a list of length less +than or equal to @var{bound}; every element of which satisfies +@var{predicate}. +@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. + +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. + +Example: +@lisp +(remove 1 '(1 2 1 3 1 4 1 5)) + @result{} (5 4 3 2) + +(remove 'foo '(bar baz bang)) + @result{} (bang baz bar) +@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. + +Example: +@lisp +(remove-if number? '(1 2 3 4)) + @result{} () + +(remove-if even? '(1 2 3 4 5 6 7 8)) + @result{} (7 5 3 1) +@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. + +Example: +@lisp +(remove-if-not number? '(foo bar baz)) + @result{} () +(remove-if-not odd? '(1 2 3 4 5 6 7 8)) + @result{} (7 5 3 1) +@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 + +The procedure @code{remove-duplicates} uses @code{member} (rather than +@code{memv}). + +@defun remove-duplicates lst +returns a copy of @var{lst} with its duplicate members removed. +Elements are considered duplicate if they are @code{equal?}. + +Example: +@lisp +(remove-duplicates '(1 2 3 4)) + @result{} (4 3 2 1) + +(remove-duplicates '(2 4 3 4)) + @result{} (3 4 2) +@end lisp +@end defun + + +@node Lists as sequences, Destructive list operations, Lists as sets, Common List Functions +@subsubsection 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}. + +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} (@pxref{Collections}) provides a version of +@code{collect} generalized to collections. + +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}. + +@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}. + +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 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 + +@defun butlast lst n +@code{butlast} returns all but the last @var{n} elements of +@var{lst}. + +Example: +@lisp +(butlast '(a b c d) 3) + @result{} (a) +(butlast '(a b c d) 4) + @result{} () +@end lisp +@end defun + +@noindent +@code{last} and @code{butlast} split a list into two parts when given +identical arugments. +@example +(last '(a b c d e) 2) + @result{} (d e) +(butlast '(a b c d e) 2) + @result{} (a b c) +@end example + +@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 '(a b c d)) + @result{} (c d) +(nthcdr 0 '(a b c d)) + @result{} (a b c d) +@end lisp +@end defun + +@defun butnthcdr n lst +@code{butnthcdr} returns all but the nthcdr @var{n} elements of +@var{lst}. + +Example: +@lisp +(butnthcdr 3 '(a b c d)) + @result{} (a b c) +(butnthcdr 4 '(a b c d)) + @result{} (a b c d) +@end lisp +@end defun + +@noindent +@code{nthcdr} and @code{butnthcdr} split a list into two parts when +given identical arugments. +@example +(nthcdr 2 '(a b c d e)) + @result{} (c d e) +(butnthcdr 2 '(a b c d e)) + @result{} (a b) +@end example + + + +@node Destructive list operations, Non-List functions, Lists as sequences, Common List Functions +@subsubsection 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!} (@pxref{Rev2 Procedures}). + +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. + +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!}. + +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}. + +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 +@subsubsection 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 + + +@node Tree Operations, Type Coercion, Common List Functions, Procedures +@subsection Tree operations + +@code{(require 'tree)} +@ftindex 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. + +@code{substq} and @code{substv} are similar, but test against @var{old} +using @code{eq?} and @code{eqv?} respectively. + +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. + +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 Type Coercion, Chapter Ordering, Tree Operations, Procedures +@subsection Type Coercion +@code{(require 'coerce)} +@ftindex coerce + +@include coerce.txi + + +@node Chapter Ordering, Sorting, Type Coercion, Procedures +@subsection Chapter Ordering + +@code{(require 'chapter-order)} +@ftindex 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 Sorting, Topological Sort, Chapter Ordering, Procedures +@subsection Sorting + +@code{(require 'sort)} +@ftindex 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}. + +@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)}). + +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. +@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, String-Case, Sorting, Procedures +@subsection Topological Sort + +@code{(require 'topological-sort)} or @code{(require 'tsort)} +@ftindex topological-sort +@ftindex 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) +@ftindex 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 String-Case, String Ports, Topological Sort, Procedures +@subsection String-Case + +@code{(require 'string-case)} +@ftindex 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 + +@defun string-ci->symbol str +Converts string @var{str} to a symbol having the same case as if the +symbol had been @code{read}. +@end defun + +@defun symbol-append obj1 @dots{} +Converts @var{obj1} @dots{} to strings, appends them, and converts to a +symbol which is returned. Strings and numbers are converted to read's +symbol case; the case of symbol characters is not changed. #f is +converted to the empty string (symbol). +@end defun + + + +@node String Ports, String Search, String-Case, Procedures +@subsection String Ports + +@code{(require 'string-port)} +@ftindex 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. +@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. +@end deffn + + +@node String Search, Line I/O, String Ports, Procedures +@subsection String Search + +@code{(require 'string-search)} +@ftindex string-search + +@deffn Procedure string-index string char +@deffnx Procedure string-index-ci 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 string-reverse-index string char +@deffnx Procedure string-reverse-index-ci string char +Returns the index of the last 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 +@deffnx procedure substring-ci? 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 +Looks for a string @var{str} within the first @var{max-no-chars} chars +of the input port @var{in-port}. + +@deffnx Procedure find-string-from-port? str in-port +When called with two arguments, the search span is limited by the end of +the input stream. + +@deffnx Procedure find-string-from-port? str in-port char +Searches up to the first occurrence of character @var{char} in +@var{str}. + +@deffnx Procedure find-string-from-port? str in-port proc +Searches up to the first occurrence of the procedure @var{proc} +returning non-false when called with a character (from @var{in-port}) +argument. + +When the @var{str} is found, @code{find-string-from-port?} 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 + +@defun string-subst txt old1 new1 @dots{} +Returns a copy of string @var{txt} with all occurrences of string +@var{old1} in @var{txt} replaced with @var{new1}, @var{old2} replaced +with @var{new2} @dots{}. +@end defun + +@node Line I/O, Multi-Processing, String Search, Procedures +@subsection Line I/O + +@code{(require 'line-i/o)} +@ftindex line-i + +@include lineio.txi + + +@node Multi-Processing, Metric Units, Line I/O, Procedures +@subsection Multi-Processing + +@code{(require 'process)} +@ftindex process + +This module implements asynchronous (non-polled) time-sliced +multi-processing in the SCM Scheme implementation using procedures +@code{alarm} and @code{alarm-interrupt}. +@findex alarm +@findex alarm-interrupt +Until this is ported to another implementation, consider it an example +of writing schedulers in Scheme. + +@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. +@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. +@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 (@pxref{System}). +@end deffn + + +@node Metric Units, , Multi-Processing, Procedures +@subsection Metric Units + +@code{(require 'metric-units)} +@ftindex metric-units + +@url{http://swissnet.ai.mit.edu/~jaffer/MIXF.html} + +@dfn{Metric Interchange Format} is a character string encoding for +numerical values and units which: + +@itemize @bullet +@item +is unambiguous in all locales; + +@item +uses only [TOG] "Portable Character Set" characters matching "Basic +Latin" characters in Plane 0 of the Universal Character Set [UCS]; + +@item +is transparent to [UTF-7] and [UTF-8] UCS transformation formats; + +@item +is human readable and writable; + +@item +is machine readable and writable; + +@item +incorporates SI prefixes and units; + +@item +incorporates [ISO 6093] numbers; and + +@item +incorporates [IEC 60027-2] binary prefixes. +@end itemize + +In the expression for the value of a quantity, the unit symbol is placed +after the numerical value. A dot (PERIOD, @samp{.}) is placed between +the numerical value and the unit symbol. + +Within a compound unit, each of the base and derived symbols can +optionally have an attached SI prefix. + +Unit symbols formed from other unit symbols by multiplication are +indicated by means of a dot (PERIOD, @samp{.}) placed between them. + +Unit symbols formed from other unit symbols by division are indicated by +means of a SOLIDUS (@samp{/}) or negative exponents. The SOLIDUS must +not be repeated in the same compound unit unless contained within a +parenthesized subexpression. + +The grouping formed by a prefix symbol attached to a unit symbol +constitutes a new inseparable symbol (forming a multiple or submultiple +of the unit concerned) which can be raised to a positive or negative +power and which can be combined with other unit symbols to form compound +unit symbols. + +The grouping formed by surrounding compound unit symbols with +parentheses (@samp{(} and @samp{)}) constitutes a new inseparable symbol +which can be raised to a positive or negative power and which can be +combined with other unit symbols to form compound unit symbols. + +Compound prefix symbols, that is, prefix symbols formed by the +juxtaposition of two or more prefix symbols, are not permitted. + +Prefix symbols are not used with the time-related unit symbols min +(minute), h (hour), d (day). No prefix symbol may be used with dB +(decibel). Only submultiple prefix symbols may be used with the unit +symbols L (liter), Np (neper), o (degree), oC (degree Celsius), rad +(radian), and sr (steradian). Submultiple prefix symbols may not be +used with the unit symbols t (metric ton), r (revolution), or Bd (baud). + +A unit exponent follows the unit, separated by a CIRCUMFLEX (@samp{^}). +Exponents may be positive or negative. Fractional exponents must be +parenthesized. + +@subsubheading SI Prefixes +@example + Factor Name Symbol | Factor Name Symbol + ====== ==== ====== | ====== ==== ====== + 1e24 yotta Y | 1e-1 deci d + 1e21 zetta Z | 1e-2 centi c + 1e18 exa E | 1e-3 milli m + 1e15 peta P | 1e-6 micro u + 1e12 tera T | 1e-9 nano n + 1e9 giga G | 1e-12 pico p + 1e6 mega M | 1e-15 femto f + 1e3 kilo k | 1e-18 atto a + 1e2 hecto h | 1e-21 zepto z + 1e1 deka da | 1e-24 yocto y +@end example + +@subsubheading Binary Prefixes + +These binary prefixes are valid only with the units B (byte) and bit. +However, decimal prefixes can also be used with bit; and decimal +multiple (not submultiple) prefixes can also be used with B (byte). + +@example + Factor (power-of-2) Name Symbol + ====== ============ ==== ====== + 1.152921504606846976e18 (2^60) exbi Ei + 1.125899906842624e15 (2^50) pebi Pi + 1.099511627776e12 (2^40) tebi Ti + 1.073741824e9 (2^30) gibi Gi + 1.048576e6 (2^20) mebi Mi + 1.024e3 (2^10) kibi Ki +@end example + +@subsubheading Unit Symbols + +@example + Type of Quantity Name Symbol Equivalent + ================ ==== ====== ========== +time second s +time minute min = 60.s +time hour h = 60.min +time day d = 24.h +frequency hertz Hz s^-1 +signaling rate baud Bd s^-1 +length meter m +volume liter L dm^3 +plane angle radian rad +solid angle steradian sr rad^2 +plane angle revolution * r = 6.283185307179586.rad +plane angle degree * o = 2.777777777777778e-3.r +information capacity bit bit +information capacity byte, octet B = 8.bit +mass gram g +mass ton t Mg +mass unified atomic mass unit u = 1.66053873e-27.kg +amount of substance mole mol +catalytic activity katal kat mol/s +thermodynamic temperature kelvin K +centigrade temperature degree Celsius oC +luminous intensity candela cd +luminous flux lumen lm cd.sr +illuminance lux lx lm/m^2 +force newton N m.kg.s^-2 +pressure, stress pascal Pa N/m^2 +energy, work, heat joule J N.m +energy electronvolt eV = 1.602176462e-19.J +power, radiant flux watt W J/s +logarithm of power ratio neper Np +logarithm of power ratio decibel * dB = 0.1151293.Np +electric current ampere A +electric charge coulomb C s.A +electric potential, EMF volt V W/A +capacitance farad F C/V +electric resistance ohm Ohm V/A +electric conductance siemens S A/V +magnetic flux weber Wb V.s +magnetic flux density tesla T Wb/m^2 +inductance henry H Wb/A +radionuclide activity becquerel Bq s^-1 +absorbed dose energy gray Gy m^2.s^-2 +dose equivalent sievert Sv m^2.s^-2 +@end example + +* The formulas are: + +@itemize @bullet +@item +r/rad = 8 * atan(1) +@item +o/r = 1 / 360 +@item +db/Np = ln(10) / 20 +@end itemize + +@defun si:conversion-factor to-unit from-unit +If the strings @var{from-unit} and @var{to-unit} express valid unit +expressions for quantities of the same unit-dimensions, then the value +returned by @code{si:conversion-factor} will be such that multiplying a +numerical value expressed in @var{from-unit}s by the returned conversion +factor yields the numerical value expressed in @var{to-unit}s. + +Otherwise, @code{si:conversion-factor} returns: + +@table @asis +@item -3 +if neither @var{from-unit} nor @var{to-unit} is a syntactically valid +unit. +@item -2 +if @var{from-unit} is not a syntactically valid unit. +@item -1 +if @var{to-unit} is not a syntactically valid unit. +@item 0 +if linear conversion (by a factor) is not possible. +@end table + +@end defun + +@example +(si:conversion-factor "km/s" "m/s" ) @result{} 0.001 +(si:conversion-factor "N" "m/s" ) @result{} 0 +(si:conversion-factor "moC" "oC" ) @result{} 1000 +(si:conversion-factor "mK" "oC" ) @result{} 0 +(si:conversion-factor "rad" "o" ) @result{} 0.0174533 +(si:conversion-factor "K" "o" ) @result{} 0 +(si:conversion-factor "K" "K" ) @result{} 1 +(si:conversion-factor "oK" "oK" ) @result{} -3 +(si:conversion-factor "" "s/s" ) @result{} 1 +(si:conversion-factor "km/h" "mph" ) @result{} -2 +@end example + + +@node Standards Support, Session Support, Procedures, Other Packages +@section 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 +* Eval:: 'eval +* Values:: 'values +@end menu + +@node With-File, Transcripts, Standards Support, Standards Support +@subsection With-File + +@code{(require 'with-file)} +@ftindex 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 +@subsection Transcripts + +@code{(require 'transcript)} +@ftindex 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}. +@end defun + + + + + +@node Rev2 Procedures, Rev4 Optional Procedures, Transcripts, Standards Support +@subsection Rev2 Procedures + +@code{(require 'rev2-procedures)} +@ftindex 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. + +@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). + +@code{substring-move-left!} stores characters in time order of +increasing indices. @code{substring-move-right!} stores characters in +time order of increasing indeces. +@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}. +@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 +@subsection Rev4 Optional Procedures + +@code{(require 'rev4-optional-procedures)} +@ftindex 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 +@subsection Multi-argument / and - + +@code{(require 'mutliarg/and-)} +@ftindex mutliarg + +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. + +@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 +@subsection Multi-argument Apply + +@code{(require 'multiarg-apply)} +@ftindex 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 +@subsection Rationalize + +@code{(require 'rationalize)} +@ftindex rationalize + +The procedure @dfn{rationalize} is interesting because most programming +languages do not provide anything analogous to it. Thanks to Alan +Bawden for contributing this algorithm. + +@defun rationalize x y +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. +@end defun + +@code{Rationalize} has limited use in implementations lacking exact +(non-integer) rational numbers. The following procedures return a list +of the numerator and denominator. + +@defun find-ratio x y +@code{find-ratio} returns the list of the @emph{simplest} +numerator and denominator whose quotient differs from @var{x} by no more +than @var{y}. + +@format +@t{(find-ratio 3/97 .0001) @result{} (3 97) +(find-ratio 3/97 .001) @result{} (1 32) +} +@end format +@end defun + +@defun find-ratio-between x y +@code{find-ratio-between} returns the list of the @emph{simplest} +numerator and denominator between @var{x} and @var{y}. + +@format +@t{(find-ratio-between 2/7 3/5) @result{} (1 2) +(find-ratio-between -3/5 -2/7) @result{} (-1 2) +} +@end format +@end defun + + +@node Promises, Dynamic-Wind, Rationalize, Standards Support +@subsection Promises + +@code{(require 'promise)} +@ftindex 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, Eval, Promises, Standards Support +@subsection Dynamic-Wind + +@code{(require 'dynamic-wind)} +@ftindex 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. + +@deffn Procedure dynamic-wind thunk1 thunk2 thunk3 +The arguments @var{thunk1}, @var{thunk2}, and @var{thunk3} must all be +procedures of no arguments (thunks). + +@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. +@end deffn + + +@node Eval, Values, Dynamic-Wind, Standards Support +@subsection Eval + +@code{(require 'eval)} + +@defun eval expression environment-specifier + +Evaluates @var{expression} in the specified environment and returns its +value. @var{Expression} must be a valid Scheme expression represented +as data, and @var{environment-specifier} must be a value returned by one +of the three procedures described below. Implementations may extend +@code{eval} to allow non-expression programs (definitions) as the first +argument and to allow other values as environments, with the restriction +that @code{eval} is not allowed to create new bindings in the +environments associated with @code{null-environment} or +@code{scheme-report-environment}. + +@lisp +(eval '(* 7 3) (scheme-report-environment 5)) + @result{} 21 + +(let ((f (eval '(lambda (f x) (f x x)) + (null-environment)))) + (f + 10)) + @result{} 20 +@end lisp +@end defun + +@defun scheme-report-environment version +@defunx null-environment version +@defunx null-environment + +@var{Version} must be an exact non-negative integer @var{n} +corresponding to a version of one of the Revised^@var{n} Reports on +Scheme. @code{Scheme-report-environment} returns a specifier for an +environment that contains the set of bindings specified in the +corresponding report that the implementation supports. +@code{Null-environment} returns a specifier for an environment that +contains only the (syntactic) bindings for all the syntactic keywords +defined in the given version of the report. + +Not all versions may be available in all implementations at all times. +However, an implementation that conforms to version @var{n} of the +Revised^@var{n} Reports on Scheme must accept version @var{n}. An error +is signalled if the specified version is not available. + +The effect of assigning (through the use of @code{eval}) a variable +bound in a @code{scheme-report-environment} (for example @code{car}) is +unspecified. Thus the environments specified by +@code{scheme-report-environment} may be immutable. + +@end defun + +@defun interaction-environment + +This optional procedure returns a specifier for the environment that +contains implementation-defined bindings, typically a superset of those +listed in the report. The intent is that this procedure will return the +environment in which the implementation would evaluate expressions +dynamically typed by the user. +@end defun + +@noindent +Here are some more @code{eval} examples: + +@example +(require 'eval) +@result{} #<unspecified> +(define car 'volvo) +@result{} #<unspecified> +car +@result{} volvo +(eval 'car (interaction-environment)) +@result{} volvo +(eval 'car (scheme-report-environment 5)) +@result{} #<primitive-procedure car> +(eval '(eval 'car (interaction-environment)) + (scheme-report-environment 5)) +@result{} volvo +(eval '(eval '(set! car 'buick) (interaction-environment)) + (scheme-report-environment 5)) +@result{} #<unspecified> +car +@result{} buick +(eval 'car (scheme-report-environment 5)) +@result{} #<primitive-procedure car> +(eval '(eval 'car (interaction-environment)) + (scheme-report-environment 5)) +@result{} buick +@end example + + +@node Values, , Eval, Standards Support +@subsection Values + +@code{(require 'values)} +@ftindex values + +@defun values obj @dots{} +@code{values} takes any number of arguments, and passes (returns) them +to its continuation. +@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. + +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. +@end defun + + +@node Session Support, Extra-SLIB Packages, Standards Support, Other Packages +@section Session Support + +@menu +* Repl:: Macros at top-level +* Quick Print:: Loop-safe Output +* Debug:: To err is human ... +* Breakpoints:: Pause execution +* Trace:: 'trace +* System Interface:: 'system, 'getenv, and 'net-clients +@end menu + + +@node Repl, Quick Print, Session Support, Session Support +@subsection Repl + +@code{(require 'repl)} +@ftindex 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}. +@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}. + +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) +@ftindex macro +(require 'repl) +@ftindex repl +(repl:top-level macro:eval) +@end lisp + +@node Quick Print, Debug, Repl, Session Support +@subsection Quick Print + +@code{(require 'qp)} +@ftindex 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 @ref{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. +@end deffn + +@defvar *qp-width* +@code{*qp-width*} is the largest number of characters that @code{qp} +should use. +@end defvar + +@node Debug, Breakpoints, Quick Print, Session Support +@subsection Debug + +@code{(require 'debug)} +@ftindex 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) +@ftindex debug +@end example + +@deffn Procedure trace-all file @dots{} +Traces (@pxref{Trace}) all procedures @code{define}d at top-level in +@file{file} @dots{}. +@deffnx Procedure track-all file @dots{} +Tracks (@pxref{Trace}) all procedures @code{define}d at top-level in +@file{file} @dots{}. +@deffnx Procedure stack-all file @dots{} +Stacks (@pxref{Trace}) all procedures @code{define}d at top-level in +@file{file} @dots{}. +@end deffn + +@deffn Procedure break-all file @dots{} +Breakpoints (@pxref{Breakpoints}) all procedures @code{define}d at +top-level in @file{file} @dots{}. +@end deffn + +@node Breakpoints, Trace, Debug, Session Support +@subsection Breakpoints + +@code{(require 'break)} +@ftindex 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 +@ftindex break +@code{(require 'debug)} telling you to type @code{(init-debug)}. This +@ftindex debug +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 + +These are @emph{procedures} for breaking. If defmacros are not natively +supported by your implementation, these might be more convenient to use. + +@defun breakf proc +@defunx 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 +To unbreak, type +@lisp +(set! @var{symbol} (unbreakf @var{symbol})) +@end lisp +@end defun + +@node Trace, System Interface, Breakpoints, Session Support +@subsection Tracing + +@code{(require 'trace)} +@ftindex trace + +@noindent +This feature provides three ways to monitor procedure invocations: + +@table @asis +@item stack +Pushes the procedure-name when the procedure is called; pops when it +returns. +@item track +Pushes the procedure-name and arguments when the procedure is called; +pops when it returns. +@item trace +Pushes the procedure-name and prints @samp{CALL @var{procedure-name} +@var{arg1} @dots{}} when the procdure is called; pops and prints +@samp{RETN @var{procedure-name} @var{value}} when the procedure returns. +@end table + +@defvar debug:max-count +If a traced procedure calls itself or untraced procedures which call it, +stack, track, and trace will limit the number of stack pushes to +@var{debug:max-count}. +@end defvar + +@defun print-call-stack +@defunx print-call-stack port +Prints the call-stack to @var{port} or the current-error-port. +@end defun + + +@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 track proc1 @dots{} +Traces the top-level named procedures given as arguments. +@defmacx track +With no arguments, makes sure that all the currently tracked identifiers +are tracked (even if those identifiers have been redefined) and returns +a list of the tracked identifiers. +@end defmac + +@defmac stack proc1 @dots{} +Traces the top-level named procedures given as arguments. +@defmacx stack +With no arguments, makes sure that all the currently stacked identifiers +are stacked (even if those identifiers have been redefined) and returns +a list of the stacked identifiers. +@end defmac + +@defmac untrace proc1 @dots{} +Turns tracing, tracking, and 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 + +@defmac untrack proc1 @dots{} +Turns tracing, tracking, and off for its arguments. +@defmacx untrack +With no arguments, untracks all currently tracked identifiers and returns +a list of these formerly tracked identifiers. +@end defmac + +@defmac unstack proc1 @dots{} +Turns tracing, stacking, and off for its arguments. +@defmacx unstack +With no arguments, unstacks all currently stacked identifiers and returns +a list of these formerly stacked identifiers. +@end defmac + +These are @emph{procedures} for tracing. If defmacros are not natively +supported by your implementation, these might be more convenient to use. + +@defun tracef proc +@defunx 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 +Removes tracing, tracking, or stacking for @var{proc}. +To untrace, type +@lisp +(set! @var{symbol} (untracef @var{symbol})) +@end lisp +@end defun + + +@node System Interface, , Trace, Session Support +@subsection System Interface + +@noindent +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 + +@noindent +If @code{(provided? 'system)}: + +@defun system command-string +Executes the @var{command-string} on the computer and returns the +integer status code. +@end defun + +@noindent +If @code{system} is provided by the Scheme implementation, the +@dfn{net-clients} package provides interfaces to common network client +programs like FTP, mail, and Netscape. + +@code{(require 'net-clients)} +@ftindex net-clients + +@include nclients.txi + + +@node Extra-SLIB Packages, , Session Support, Other Packages +@section Extra-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). + +@ifset html +<A HREF="http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz"> +@end ifset +http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz +@ifset html +</A> +@end ifset + +swissnet.ai.mit.edu:/pub/scm/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 +@sp 1 + +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 +@ifset html +<A HREF="http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html"> +@end ifset +http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html +@ifset html +</A> +@end ifset +@sp 1 + +@item SCHELOG +is an embedding of Prolog in Scheme. +@ifset html +<A HREF="http://www.cs.rice.edu/CS/PLT/packages/schelog/"> +@end ifset +http://www.cs.rice.edu/CS/PLT/packages/schelog/ +@ifset html +</A> +@end ifset +@sp 1 + +@item JFILTER +is a Scheme program which converts text among the JIS, EUC, and Shift-JIS Japanese character sets. +@ifset html +<A HREF="http://www.sci.toyama-u.ac.jp/~iwao/Scheme/Jfilter/index.html"> +@end ifset +http://www.sci.toyama-u.ac.jp/~iwao/Scheme/Jfilter/index.html +@ifset html +</A> +@end ifset +@end table + + +@node About SLIB, Index, Other Packages, Top +@chapter About SLIB + +@ifinfo +@noindent +More people than I can name have contributed to SLIB. Thanks to all of +you! + +@quotation +SLIB @value{SLIBVERSION}, released @value{SLIBDATE}.@* +Aubrey Jaffer <jaffer @@ ai.mit.edu>@* +@i{Hyperactive Software} -- The Maniac Inside!@* +@url{http://swissnet.ai.mit.edu/~jaffer/SLIB.html} +@end quotation +@end ifinfo + +@menu +* Installation:: How to install SLIB on your system. +* Porting:: SLIB to new platforms. +* Coding Guidelines:: How to write modules for SLIB. +* Copyrights:: Intellectual propery issues. +@end menu + + +@node Installation, Porting, About SLIB, About SLIB +@section Installation + + +@ifset html +<A NAME="Installation"> +@end ifset +@ifset html +</A> +@end ifset + +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}. Scheme48 +supports @code{getenv} but does not use it for determining +@code{library-vicinity}. (That is done from the Makefile.) + +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. + +@deftp Implementation SCM +The SCM implementation does not require any initialization file as SLIB +support is already built into SCM. See the documentation with SCM for +installation instructions. +@end deftp + +@deftp Implementation VSCM +@format +From: Matthias Blume <blume@@cs.Princeton.EDU> +Date: Tue, 1 Mar 1994 11:42:31 -0500 +@end format + +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. + +You have to provide @file{vscm.init} as an explicit command line +argument. Since this is not very nice I would recommend the following +installation procedure: + +@enumerate +@item +run scheme +@item +@code{(load "vscm.init")} +@item +@code{(slib:dump "dumpfile")} +@item +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.) +@end enumerate + +@end deftp + +@deftp Implementation Scheme48 +To make a Scheme48 image for an installation under @code{<prefix>}, + +@enumerate +@item +@code{cd} to the SLIB directory +@item +type @code{make prefix=<prefix> slib48}. +@item +To install the image, type @code{make prefix=<prefix> install48}. This +will also create a shell script with the name @code{slib48} which will +invoke the saved image. +@end enumerate +@end deftp + +@deftp Implementation {PLT Scheme} +@deftpx Implementation {DrScheme} +@deftpx Implementation {MzScheme} +@format +Date: Mon, 2 Oct 2000 21:29:48 -0400 (EDT) +From: Shriram Krishnamurthi <sk@@cs.brown.edu> +@end format + +We distribute an SLIB init file for our system. If you have PLT Scheme +(our preferred name for the entire suite, which includes DrScheme, +MzScheme and other implementations) installed, you ought to be able to +run @dfn{help-desk}, or run @samp{drscheme} and choose Help Desk from +the Help menu; in Help Desk, type @samp{slib}. This will give +instructions for how to load the SLIB init file. +@end deftp + + +@node Porting, Coding Guidelines, Installation, About SLIB +@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}, @cite{Revised^4 Report on the +Algorithmic Language Scheme}, or @cite{Revised^5 Report on the +Algorithmic Language Scheme} in order to support SLIB. @footnote{If you +are porting a @cite{Revised^3 Report on the Algorithmic Language Scheme} +implementation, then you will need to finish writing @file{sc4sc3.scm} +and @code{load} it from your initialization file.} + +@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} from +the library; this will allow the use of @code{provide}, +@code{provided?}, and @code{require} along with the @dfn{vicinity} +functions (these functions are documented in the section @ref{Require}). +The rest of the library will then be accessible in a system independent +fashion. + +Please mail new working configuration files to @code{jaffer @@ ai.mit.edu} +so that they can be included in the SLIB distribution. + + +@node Coding Guidelines, Copyrights, Porting, About SLIB +@section Coding Guidelines + +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)} (@pxref{Require}). +@ftindex rev3-report + +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)}. + +Code submitted for inclusion in SLIB should not duplicate routines +already in SLIB files. Use @code{require} to force those library +routines to be used by your package. Care should be taken that there +are no circularities in the @code{require}s and @code{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 @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, , Coding Guidelines, About SLIB +@section Copyrights + +@ifset html +<A NAME="Copyrights"> +@end ifset +@ifset html +</A> +@end ifset + +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 Index, , About SLIB, Top +@c @node Procedure and Macro Index, Variable Index, About SLIB, Top +@unnumbered Procedure and Macro Index + +This is an alphabetical list of all the procedures and macros in SLIB. + +@printindex fn + +@c @node Variable Index, Concept Index, Procedure and Macro Index, Top +@unnumbered Variable Index + +This is an alphabetical list of all the global variables in SLIB. + +@printindex vr + +@c @node Concept Index, , Variable Index, Top +@unnumbered Concept and Feature Index + +@printindex cp + +@contents +@bye diff --git a/module/slib/sort.scm b/module/slib/sort.scm new file mode 100644 index 000000000..cfa37f94b --- /dev/null +++ b/module/slib/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) + (vector-ref seq (- i 1)))) + (= 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/module/slib/soundex.scm b/module/slib/soundex.scm new file mode 100644 index 000000000..eb3a542f0 --- /dev/null +++ b/module/slib/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/module/slib/stdio.scm b/module/slib/stdio.scm new file mode 100644 index 000000000..2feb0dfa6 --- /dev/null +++ b/module/slib/stdio.scm @@ -0,0 +1,8 @@ +;; "stdio.scm" compatability stub + +(require 'scanf) +(require 'printf) + +(define stdin (current-input-port)) +(define stdout (current-output-port)) +(define stderr (current-error-port)) diff --git a/module/slib/strcase.scm b/module/slib/strcase.scm new file mode 100644 index 000000000..30b58ada7 --- /dev/null +++ b/module/slib/strcase.scm @@ -0,0 +1,66 @@ +;;; "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. +; SYMBOL-APPEND added by A. Jaffer 2001. +; 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))) + +(define string-ci->symbol + (let ((s2cis (if (equal? "x" (symbol->string 'x)) + string-downcase string-upcase))) + (lambda (str) (string->symbol (s2cis str))))) + +(define symbol-append + (let ((s2cis (if (equal? "x" (symbol->string 'x)) + string-downcase string-upcase))) + (lambda args + (string->symbol + (apply string-append + (map + (lambda (obj) + (cond ((string? obj) (s2cis obj)) + ((number? obj) (s2cis (number->string obj))) + ((symbol? obj) (symbol->string obj)) + ((not obj) "") + (else (slib:error 'wrong-type-to 'symbol-append obj)))) + args)))))) diff --git a/module/slib/strport.scm b/module/slib/strport.scm new file mode 100644 index 000000000..a75ab0aa7 --- /dev/null +++ b/module/slib/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 (string c))) + (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/module/slib/strsrch.scm b/module/slib/strsrch.scm new file mode 100644 index 000000000..71c69df61 --- /dev/null +++ b/module/slib/strsrch.scm @@ -0,0 +1,146 @@ +;;; "MISCIO" Search for string from port. +; Written 1995, 1996 by Oleg Kiselyov (oleg@ponder.csci.unt.edu) +; Modified 1996, 1997, 1998 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 (string-index-ci str a-char) + (let loop ((pos 0)) + (cond + ;; whole string has been searched, in vain + ((>= pos (string-length str)) #f) + ((char-ci=? a-char (string-ref str pos)) pos) + (else (loop (+ 1 pos)))))) + +(define (string-reverse-index str a-char) + (let loop ((pos (- (string-length str) 1))) + (cond ((< pos 0) #f) + ((char=? (string-ref str pos) a-char) pos) + (else (loop (- pos 1)))))) + +(define (string-reverse-index-ci str a-char) + (let loop ((pos (- (string-length str) 1))) + (cond ((< pos 0) #f) + ((char-ci=? (string-ref str pos) a-char) pos) + (else (loop (- pos 1)))))) + +(define (miscio:substring? pattern str char=?) + (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 (substring? pattern str) (miscio:substring? pattern str char=?)) +(define (substring-ci? pattern str) (miscio:substring? pattern str char-ci=?)) + +(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) + (peeked? #f) + (my-peek-char ; Return a peeked char or #f + (lambda () (and (or (not (number? max-no-char)) + (< no-chars-read max-no-char)) + (let ((c (peek-char <input-port>))) + (cond (peeked? c) + ((eof-object? c) #f) + ((procedure? max-no-char) + (set! peeked? #t) + (if (max-no-char c) #f c)) + ((eqv? max-no-char c) #f) + (else c)))))) + (next-char (lambda () (set! peeked? #f) (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))) + (and c + (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))) + +(define (string-subst text old new . rest) + (define sub + (lambda (text) + (set! text + (cond ((equal? "" text) text) + ((substring? old text) + => (lambda (idx) + (string-append + (substring text 0 idx) + new + (sub (substring + text (+ idx (string-length old)) + (string-length text)))))) + (else text))) + (if (null? rest) + text + (apply string-subst text rest)))) + (sub text)) + diff --git a/module/slib/struct.scm b/module/slib/struct.scm new file mode 100644 index 000000000..100d3ff34 --- /dev/null +++ b/module/slib/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/module/slib/structst.scm b/module/slib/structst.scm new file mode 100644 index 000000000..ea298e048 --- /dev/null +++ b/module/slib/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/module/slib/structure.scm b/module/slib/structure.scm new file mode 100644 index 000000000..0d379b969 --- /dev/null +++ b/module/slib/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/module/slib/syncase.sh b/module/slib/syncase.sh new file mode 100644 index 000000000..4ae4db4fc --- /dev/null +++ b/module/slib/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/module/slib/synchk.scm b/module/slib/synchk.scm new file mode 100644 index 000000000..7e45a73db --- /dev/null +++ b/module/slib/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/module/slib/synclo.scm b/module/slib/synclo.scm new file mode 100644 index 000000000..3c61de330 --- /dev/null +++ b/module/slib/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/module/slib/synrul.scm b/module/slib/synrul.scm new file mode 100644 index 000000000..c23275fd2 --- /dev/null +++ b/module/slib/synrul.scm @@ -0,0 +1,327 @@ +;;; "synrul.scm" Rule-based Syntactic Expanders -*-Scheme-*- +;;; Copyright (c) 1989-91 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of Electrical +;;; Engineering and Computer Science. Permission to copy this +;;; software, to redistribute it, and to use it for any purpose is +;;; granted, subject to the following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions +;;; that they make, so that these may be included in future releases; +;;; and (b) to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the +;;; usual standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation +;;; of this software will be error-free, and MIT is under no +;;; obligation to provide any services, by way of maintenance, update, +;;; or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the Massachusetts +;;; Institute of Technology nor of any adaptation thereof in any +;;; advertising, promotional, or sales literature without prior +;;; written consent from MIT in each case. + +;;;; Rule-based Syntactic Expanders + +;;; See "Syntactic Extensions in the Programming Language Lisp", by +;;; Eugene Kohlbecker, Ph.D. dissertation, Indiana University, 1986. +;;; See also "Macros That Work", by William Clinger and Jonathan Rees +;;; (reference? POPL?). This implementation is derived from an +;;; implementation by Kent Dybvig, and includes some ideas from +;;; another implementation by Jonathan Rees. + +;;; The expansion of SYNTAX-RULES references the following keywords: +;;; ER-TRANSFORMER LAMBDA IF BEGIN SET! QUOTE +;;; and the following procedures: +;;; CAR CDR NULL? PAIR? EQUAL? MAP LIST CONS APPEND +;;; ILL-FORMED-SYNTAX +;;; it also uses the anonymous keyword SYNTAX-QUOTE. + +;;; For testing. +;;;(define (run-sr form) +;;; (expand/syntax-rules form (lambda (x) x) eq?)) + +(define (make-syntax-rules-macrology) + (make-er-expander-macrology + (lambda (define-classifier base-environment) + base-environment ;ignore + (define-classifier 'SYNTAX-RULES expand/syntax-rules)))) + +(define (expand/syntax-rules form rename compare) + (if (syntax-match? '((* IDENTIFIER) + ((IDENTIFIER . DATUM) EXPRESSION)) + (cdr form)) + (let ((keywords (cadr form)) + (clauses (cddr form))) + (if (let loop ((keywords keywords)) + (and (pair? keywords) + (or (memq (car keywords) (cdr keywords)) + (loop (cdr keywords))))) + (syntax-error "keywords list contains duplicates" keywords) + (let ((r-form (rename 'FORM)) + (r-rename (rename 'RENAME)) + (r-compare (rename 'COMPARE))) + `(,(rename 'ER-TRANSFORMER) + (,(rename 'LAMBDA) + (,r-form ,r-rename ,r-compare) + ,(let loop ((clauses clauses)) + (if (null? clauses) + `(,(rename 'ILL-FORMED-SYNTAX) ,r-form) + (let ((pattern (caar clauses))) + (let ((sids + (parse-pattern rename compare keywords + pattern r-form))) + `(,(rename 'IF) + ,(generate-match rename compare keywords + r-rename r-compare + pattern r-form) + ,(generate-output rename compare r-rename + sids (cadar clauses) + syntax-error) + ,(loop (cdr clauses)))))))))))) + (ill-formed-syntax form))) + +(define (parse-pattern rename compare keywords pattern expression) + (let loop + ((pattern pattern) + (expression expression) + (sids '()) + (control #f)) + (cond ((identifier? pattern) + (if (memq pattern keywords) + sids + (cons (make-sid pattern expression control) sids))) + ((and (or (zero-or-more? pattern rename compare) + (at-least-one? pattern rename compare)) + (null? (cddr pattern))) + (let ((variable ((make-name-generator) 'CONTROL))) + (loop (car pattern) + variable + sids + (make-sid variable expression control)))) + ((pair? pattern) + (loop (car pattern) + `(,(rename 'CAR) ,expression) + (loop (cdr pattern) + `(,(rename 'CDR) ,expression) + sids + control) + control)) + (else sids)))) + +(define (generate-match rename compare keywords r-rename r-compare + pattern expression) + (letrec + ((loop + (lambda (pattern expression) + (cond ((identifier? pattern) + (if (memq pattern keywords) + (let ((temp (rename 'TEMP))) + `((,(rename 'LAMBDA) + (,temp) + (,(rename 'IF) + (,(rename 'IDENTIFIER?) ,temp) + (,r-compare ,temp + (,r-rename ,(syntax-quote pattern))) + #f)) + ,expression)) + `#t)) + ((and (zero-or-more? pattern rename compare) + (null? (cddr pattern))) + (do-list (car pattern) expression)) + ((and (at-least-one? pattern rename compare) + (null? (cddr pattern))) + `(,(rename 'IF) (,(rename 'NULL?) ,expression) + #F + ,(do-list (car pattern) expression))) + ((pair? pattern) + (let ((generate-pair + (lambda (expression) + (conjunction + `(,(rename 'PAIR?) ,expression) + (conjunction + (loop (car pattern) + `(,(rename 'CAR) ,expression)) + (loop (cdr pattern) + `(,(rename 'CDR) ,expression))))))) + (if (identifier? expression) + (generate-pair expression) + (let ((temp (rename 'TEMP))) + `((,(rename 'LAMBDA) (,temp) ,(generate-pair temp)) + ,expression))))) + ((null? pattern) + `(,(rename 'NULL?) ,expression)) + (else + `(,(rename 'EQUAL?) ,expression + (,(rename 'QUOTE) ,pattern)))))) + (do-list + (lambda (pattern expression) + (let ((r-loop (rename 'LOOP)) + (r-l (rename 'L)) + (r-lambda (rename 'LAMBDA))) + `(((,r-lambda + (,r-loop) + (,(rename 'BEGIN) + (,(rename 'SET!) + ,r-loop + (,r-lambda + (,r-l) + (,(rename 'IF) + (,(rename 'NULL?) ,r-l) + #T + ,(conjunction + `(,(rename 'PAIR?) ,r-l) + (conjunction (loop pattern `(,(rename 'CAR) ,r-l)) + `(,r-loop (,(rename 'CDR) ,r-l))))))) + ,r-loop)) + #F) + ,expression)))) + (conjunction + (lambda (predicate consequent) + (cond ((eq? predicate #T) consequent) + ((eq? consequent #T) predicate) + (else `(,(rename 'IF) ,predicate ,consequent #F)))))) + (loop pattern expression))) + +(define (generate-output rename compare r-rename sids template syntax-error) + (let loop ((template template) (ellipses '())) + (cond ((identifier? template) + (let ((sid + (let loop ((sids sids)) + (and (not (null? sids)) + (if (eq? (sid-name (car sids)) template) + (car sids) + (loop (cdr sids))))))) + (if sid + (begin + (add-control! sid ellipses syntax-error) + (sid-expression sid)) + `(,r-rename ,(syntax-quote template))))) + ((or (zero-or-more? template rename compare) + (at-least-one? template rename compare)) + (optimized-append rename compare + (let ((ellipsis (make-ellipsis '()))) + (generate-ellipsis rename + ellipsis + (loop (car template) + (cons ellipsis + ellipses)))) + (loop (cddr template) ellipses))) + ((pair? template) + (optimized-cons rename compare + (loop (car template) ellipses) + (loop (cdr template) ellipses))) + (else + `(,(rename 'QUOTE) ,template))))) + +(define (add-control! sid ellipses syntax-error) + (let loop ((sid sid) (ellipses ellipses)) + (let ((control (sid-control sid))) + (cond (control + (if (null? ellipses) + (syntax-error "missing ellipsis in expansion" #f) + (let ((sids (ellipsis-sids (car ellipses)))) + (cond ((not (memq control sids)) + (set-ellipsis-sids! (car ellipses) + (cons control sids))) + ((not (eq? control (car sids))) + (syntax-error "illegal control/ellipsis combination" + control sids))))) + (loop control (cdr ellipses))) + ((not (null? ellipses)) + (syntax-error "extra ellipsis in expansion" #f)))))) + +(define (generate-ellipsis rename ellipsis body) + (let ((sids (ellipsis-sids ellipsis))) + (let ((name (sid-name (car sids))) + (expression (sid-expression (car sids)))) + (cond ((and (null? (cdr sids)) + (eq? body name)) + expression) + ((and (null? (cdr sids)) + (pair? body) + (pair? (cdr body)) + (eq? (cadr body) name) + (null? (cddr body))) + `(,(rename 'MAP) ,(car body) ,expression)) + (else + `(,(rename 'MAP) (,(rename 'LAMBDA) ,(map sid-name sids) ,body) + ,@(map sid-expression sids))))))) + +(define (zero-or-more? pattern rename compare) + (and (pair? pattern) + (pair? (cdr pattern)) + (identifier? (cadr pattern)) + (compare (cadr pattern) (rename '...)))) + +(define (at-least-one? pattern rename compare) +;;; (and (pair? pattern) +;;; (pair? (cdr pattern)) +;;; (identifier? (cadr pattern)) +;;; (compare (cadr pattern) (rename '+))) + pattern rename compare ;ignore + #f) + +(define (optimized-cons rename compare a d) + (cond ((and (pair? d) + (compare (car d) (rename 'QUOTE)) + (pair? (cdr d)) + (null? (cadr d)) + (null? (cddr d))) + `(,(rename 'LIST) ,a)) + ((and (pair? d) + (compare (car d) (rename 'LIST)) + (list? (cdr d))) + `(,(car d) ,a ,@(cdr d))) + (else + `(,(rename 'CONS) ,a ,d)))) + +(define (optimized-append rename compare x y) + (if (and (pair? y) + (compare (car y) (rename 'QUOTE)) + (pair? (cdr y)) + (null? (cadr y)) + (null? (cddr y))) + x + `(,(rename 'APPEND) ,x ,y))) + +(define sid-type + (make-record-type "sid" '(NAME EXPRESSION CONTROL OUTPUT-EXPRESSION))) + +(define make-sid + (record-constructor sid-type '(NAME EXPRESSION CONTROL))) + +(define sid-name + (record-accessor sid-type 'NAME)) + +(define sid-expression + (record-accessor sid-type 'EXPRESSION)) + +(define sid-control + (record-accessor sid-type 'CONTROL)) + +(define sid-output-expression + (record-accessor sid-type 'OUTPUT-EXPRESSION)) + +(define set-sid-output-expression! + (record-modifier sid-type 'OUTPUT-EXPRESSION)) + +(define ellipsis-type + (make-record-type "ellipsis" '(SIDS))) + +(define make-ellipsis + (record-constructor ellipsis-type '(SIDS))) + +(define ellipsis-sids + (record-accessor ellipsis-type 'SIDS)) + +(define set-ellipsis-sids! + (record-modifier ellipsis-type 'SIDS)) diff --git a/module/slib/t3.init b/module/slib/t3.init new file mode 100644 index 000000000..8dccfd41f --- /dev/null +++ b/module/slib/t3.init @@ -0,0 +1,437 @@ +;;; "t3.init" Initialization file for SLIB for T3.1. -*-scheme-*- +;;; Authors: David Carlton, Stephen Bevan, F. Javier Thayer, and Aubrey Jaffer. +;;; +;;; This code is in the public domain. + +;;; 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") + +;;; (scheme-implementation-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) + "ftp://ftp.cs.indiana.edu:21/pub/scheme-repository/imp/t/README") + +;;; (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. + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define (home-vicinity) #f) + +;;; *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) + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; 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) + +;;; 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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;;; define an error procedure for the library +(define (slib:error . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (apply error args)) + +;;; 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/module/slib/tek40.scm b/module/slib/tek40.scm new file mode 100644 index 000000000..f45a1faa2 --- /dev/null +++ b/module/slib/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/module/slib/tek41.scm b/module/slib/tek41.scm new file mode 100644 index 000000000..988f8ea05 --- /dev/null +++ b/module/slib/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/module/slib/timezone.scm b/module/slib/timezone.scm new file mode 100644 index 000000000..a9149e358 --- /dev/null +++ b/module/slib/timezone.scm @@ -0,0 +1,264 @@ +;;;; "timezone.scm" Compute timezones and DST from TZ environment variable. +;;; Copyright (C) 1994, 1996, 1997 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 C-library support for time in general and time-zones in particular +;; stands as a fine example of how *not* to create interfaces. +;; +;; Functions are not consistently named. Support for GMT is offered in one +;; direction only; The localtime function returns some timezone data in the +;; structure which it returns, and some data in shared global variables. +;; The structure which localtime returns is overwritten with each +;; invocation. There is no way to find local time in zones other than GMT +;; and the local timezone. +;; +;; The tzfile(5) format encodes only a single timezone per file. There is +;; no dispatch on zone names, so multiple copies of a timezone file exist +;; under different names. The TZ `:' specification is unix filesystem +;; specific. The tzfile(5) format makes no provision for byte-order +;; differences; It mixes 32-bit integer data with characters; specifying +;; ASCII bytes, it is incompatible with different character sizes. The +;; binary format makes it impossible to easily inspect a file for +;; corruption. +;; +;; I have corrected most of the failings of the C-library time interface in +;; SLIB while maintaining compatablility. I wrote support for Linux +;; timezone files because on a system where TZ is not set, there is no +;; other way to reveal this information. HP-UX appears to have a more +;; sensible arrangement; I invite you to add support for it and other +;; platforms. +;; +;; Writing this was a long, tedious, and unenlightening process. I hope it +;; is useful. +;; +;; Sat Nov 15 00:15:33 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + +(provide 'time-zone) +(require 'scanf) + +(define daylight? #f) +(define *timezone* 0) +(define tzname '#("UTC" "???")) + +(define tz:default #f) + +;;; This definition is here so that READ-TZFILE can verify the +;;; existence of these files before loading tzfile.scm to actually +;;; read them. +(define tzfile:vicinity (make-vicinity + (if (file-exists? "/usr/share/zoneinfo/.") + "/usr/share/zoneinfo/" + "/usr/lib/zoneinfo/"))) + +(define (read-tzfile path) + (let ((realpath + (cond ((not path) (in-vicinity tzfile:vicinity "localtime")) + ((or (char-alphabetic? (string-ref path 0)) + (char-numeric? (string-ref path 0))) + (in-vicinity tzfile:vicinity path)) + (else path)))) + (and (file-exists? realpath) + (let ((zone #f)) + (require 'tzfile) + (set! zone (tzfile:read realpath)) + (if zone (list->vector (cons 'tz:file zone)) + (slib:error 'read-tzfile realpath)))))) + +;;; Parse Posix TZ string. + +(define (string->transition-day-time str) + (let ((month 0) (week 0) (day #f) (junk #f)) + (or (case (sscanf str "J%u%s" day junk) + ((1) (and (<= 1 day 365) + (list #f #f day))) + (else #f)) + (case (sscanf str "%u%s" day junk) + ((1) (and (<= 0 day 365) + (list #f #t day))) + (else #f)) + (case (sscanf str "M%u.%u.%u%s" month week day junk) + ((3) (and (<= 1 month 12) + (<= 1 week 5) + (<= 0 day 6) + (list month week day))) + (else #f))))) + +(define (string->transition-time str) + (let ((date #f) (time "2") (junk #f)) + (and (or (eqv? 2 (sscanf str "%[JM.0-9]/%[:0-9]%s" date time junk)) + (eqv? 1 (sscanf str "%[JM.0-9]" date junk))) + (let ((day (string->transition-day-time date)) + (tim (string->time-offset time))) + (and day tim (append day (list tim))))))) + +(define (string->time-offset str) + (and str (string? str) (positive? (string-length str)) + (let ((hh #f) (mm 0) (ss 0) (junk #f)) + (and (<= 1 (sscanf (if (memv (string-ref str 0) '(#\+ #\-)) + (substring str 1 (string-length str)) + str) + "%u:%u:%u%s" hh mm ss junk) + 3) + hh (<= 0 hh 23) (<= 0 mm 59) (<= 0 ss 59) + (* (if (char=? #\- (string-ref str 0)) -1 1) + (+ ss (* 60 (+ mm (* hh 60))))))))) + +(define (string->time-zone tz) + (let ((tzname #f) (offset #f) (dtzname #f) (doffset #f) + (start-str #f) (end-str #f) (junk #f)) + (define found + (sscanf + tz "%[^0-9,+-]%[-:+0-9]%[^0-9,+-]%[-:+0-9],%[JM.0-9/:],%[JM.0-9/:]%s" + tzname offset dtzname doffset start-str end-str junk)) + (set! offset (string->time-offset offset)) + (set! doffset (string->time-offset doffset)) + (cond + ((and offset (eqv? 3 found)) + (set! doffset (+ -3600 offset)) + (set! found + (+ 1 + (sscanf + tz "%[^0-9,+-]%[-:+0-9]%[^0-9,+-],%[JM.0-9/:],%[JM.0-9/:]%s" + tzname offset dtzname start-str end-str junk))) + (set! offset (string->time-offset offset)))) + (case found + ((2) (vector 'tz:fixed tz tzname offset)) + ((4) (vector 'tz:rule tz tzname dtzname offset doffset + (list 4 1 0 7200) (list 10 5 0 7200))) + ((6) (let ((start (string->transition-time start-str)) + (end (string->transition-time end-str))) + (and + start end + (vector 'tz:rule tz tzname dtzname offset doffset start end)))) + (else #f)))) + +(define (time-zone tz) + (cond ((not tz) (read-tzfile #f)) + ((vector? tz) tz) + ((eqv? #\: (string-ref tz 0)) + (read-tzfile (substring tz 1 (string-length tz)))) + (else (string->time-zone tz)))) + +;;; Use the timezone + +(define (tzrule->caltime year previous-gmt-offset + tr-month tr-week tr-day tr-time) + (define leap? (leap-year? year)) + (define gmmt + (time:invert time:gmtime + (vector 0 0 0 1 (if tr-month (+ -1 tr-month) 0) year #f #f 0))) + (offset-time + gmmt + (+ tr-time previous-gmt-offset + (* 3600 24 + (if tr-month + (let* ((fdow (vector-ref (time:gmtime gmmt) 6))) + (case tr-week + ((1 2 3 4) (+ (modulo (- tr-day fdow) 7) + (* 7 (+ -1 tr-week)))) + ((5) + (do ((mmax (vector-ref + (vector-ref time:days/month (if leap? 1 0)) + (+ -1 tr-month))) + (d (modulo (- tr-day fdow) 7) (+ 7 d))) + ((>= d mmax) (+ -7 d)))) + (else (slib:error 'tzrule->caltime + "week out of range" tr-week)))) + (+ tr-day + (if (and (not tr-week) (>= tr-day 60) (leap-year? year)) + 1 0))))))) + +(define (tz:params caltime tz) + (case (vector-ref tz 0) + ((tz:fixed) (list 0 (vector-ref tz 3) (vector-ref tz 2))) + ((tz:rule) + (let* ((year (vector-ref (time:gmtime caltime) 5)) + (ttime0 (apply tzrule->caltime + year (vector-ref tz 4) (vector-ref tz 6))) + (ttime1 (apply tzrule->caltime + year (vector-ref tz 5) (vector-ref tz 7))) + (dst (if (and (not (negative? (difftime caltime ttime0))) + (negative? (difftime caltime ttime1))) + 1 0))) + (list dst (vector-ref tz (+ 4 dst)) (vector-ref tz (+ 2 dst))) + ;;(for-each display (list (gtime ttime0) (gtime caltime) (gtime ttime1))) + )) + ((tz:file) (let ((zone-spec (tzfile:get-zone-spec caltime tz))) + (list (if (vector-ref zone-spec 2) 1 0) + (- (vector-ref zone-spec 1)) + (vector-ref zone-spec 0)))) + (else (slib:error 'tz:params "unknown timezone type" tz)))) + +(define (tz:std-offset zone) + (case (vector-ref zone 0) + ((tz:fixed) (vector-ref zone 3)) + ((tz:rule) (vector-ref zone 4)) + ((tz:file) + (let ((mode-table (vector-ref zone 2))) + (do ((type-idx 0 (+ 1 type-idx))) + ((or (>= type-idx (vector-length mode-table)) + (not (vector-ref (vector-ref mode-table type-idx) 2))) + (if (>= type-idx (vector-length mode-table)) + (vector-ref (vector-ref mode-table 0) 1) + (- (vector-ref (vector-ref mode-table type-idx) 1))))))) + (else (slib:error 'tz:std-offset "unknown timezone type" tz)))) + +;;; Interpret the TZ envariable. +(define (tzset . opt-tz) + (define tz (if (null? opt-tz) + (getenv "TZ") + (car opt-tz))) + (if (or (not tz:default) + (and (string? tz) (not (string-ci=? tz (vector-ref tz:default 1))))) + (set! tz:default (or (time-zone tz) '#(tz:fixed "UTC" "GMT" 0)))) + (case (vector-ref tz:default 0) + ((tz:fixed) + (set! tzname (vector (vector-ref tz:default 2) "???")) + (set! daylight? #f) + (set! *timezone* (vector-ref tz:default 3))) + ((tz:rule) + (set! tzname (vector (vector-ref tz:default 2) + (vector-ref tz:default 3))) + (set! daylight? #t) + (set! *timezone* (vector-ref tz:default 4))) + ((tz:file) + (let ((mode-table (vector-ref tz:default 2)) + (transition-types (vector-ref tz:default 5))) + (set! daylight? #f) + (set! *timezone* (vector-ref (vector-ref mode-table 0) 1)) + (set! tzname (make-vector 2 #f)) + (do ((type-idx 0 (+ 1 type-idx))) + ((>= type-idx (vector-length mode-table))) + (let ((rec (vector-ref mode-table type-idx))) + (if (vector-ref rec 2) + (set! daylight? #t) + (set! *timezone* (- (vector-ref rec 1)))))) + + (do ((transition-idx (+ -1 (vector-length transition-types)) + (+ -1 transition-idx))) + ((or (negative? transition-idx) + (and (vector-ref tzname 0) (vector-ref tzname 1)))) + (let ((rec (vector-ref mode-table + (vector-ref transition-types transition-idx)))) + (if (vector-ref rec 2) + (if (not (vector-ref tzname 1)) + (vector-set! tzname 1 (vector-ref rec 0))) + (if (not (vector-ref tzname 0)) + (vector-set! tzname 0 (vector-ref rec 0)))))))) + (else (slib:error 'tzset "unknown timezone type" tz))) + tz:default) diff --git a/module/slib/trace.scm b/module/slib/trace.scm new file mode 100644 index 000000000..7b1893c18 --- /dev/null +++ b/module/slib/trace.scm @@ -0,0 +1,254 @@ +;;;; "trace.scm" Utility macros for tracing in Scheme. +;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2000 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 trace:indent 0) +(define debug:call-stack '()) ;keeps track of call stack. +(define debug:max-count 5) + +;;Formats for call-stack elements: +;; (procedure-count name . args) ;for debug:track procedure +;; (procedure-count name) ;for debug:stack procedure +;;Traced functions also stack. + +(define print-call-stack + (let ((car car) (null? null?) (current-error-port current-error-port) + (qpn qpn) (for-each for-each)) + (lambda cep + (set! cep (if (null? cep) (current-error-port) (car cep))) + (for-each qpn debug:call-stack)))) + +(define (call-stack-news? name) + (or (null? debug:call-stack) + (not (eq? name (cadar debug:call-stack))) + (< (caar debug:call-stack) debug:max-count))) + +(define debug:trace-procedure + (let ((null? null?) (not not) ;These bindings are so that + (cdar cdar) (cadar cadar) ;trace will not trace parts + (car car) (cdr cdr) (caar caar) ;of itself. + (eq? eq?) (+ +) (zero? zero?) (modulo modulo) + (apply apply) (display display) (qpn qpn) (list list) (cons cons) + + (CALL (string->symbol "CALL")) + (RETN (string->symbol "RETN"))) + (lambda (how function . optname) + (set! trace:indent 0) + (let ((name (if (null? optname) function (car optname)))) + (case how + ((trace) + (lambda args + (cond ((and (not (null? args)) + (eq? (car args) 'debug:untrace-object) + (null? (cdr args))) + function) + ((call-stack-news? name) + (let ((cs debug:call-stack)) + (set! debug:call-stack + (if (and (not (null? debug:call-stack)) + (eq? name (cadar debug:call-stack))) + (cons (cons (+ 1 (caar debug:call-stack)) + (cdar debug:call-stack)) + (cdr debug:call-stack)) + (cons (list 1 name) debug:call-stack))) + (do ((i trace:indent (+ -1 i))) ((zero? i)) (display #\ )) + (apply qpn CALL name args) + (set! trace:indent (modulo (+ 1 trace:indent) 16)) + (let ((ans (apply function args))) + (set! trace:indent (modulo (+ -1 trace:indent) 16)) + (do ((i trace:indent (+ -1 i))) ((zero? i)) (display #\ )) + (qpn RETN name ans) + (set! debug:call-stack cs) + ans))) + (else (apply function args))))) + ((track) + (lambda args + (cond ((and (not (null? args)) + (eq? (car args) 'debug:untrace-object) + (null? (cdr args))) + function) + ((call-stack-news? name) + (let ((cs debug:call-stack)) + (set! debug:call-stack + (if (and (not (null? debug:call-stack)) + (eq? name (cadar debug:call-stack))) + (cons (cons (+ 1 (caar debug:call-stack)) + (cdar debug:call-stack)) + (cdr debug:call-stack)) + (cons (cons 1 (cons name args)) + debug:call-stack))) + (let ((ans (apply function args))) + (set! debug:call-stack cs) + ans))) + (else (apply function args))))) + ((stack) + (lambda args + (cond ((and (not (null? args)) + (eq? (car args) 'debug:untrace-object) + (null? (cdr args))) + function) + ((call-stack-news? name) + (let ((cs debug:call-stack)) + (set! debug:call-stack + (if (and (not (null? debug:call-stack)) + (eq? name (cadar debug:call-stack))) + (cons (cons (+ 1 (caar debug:call-stack)) + (cdar debug:call-stack)) + (cdr debug:call-stack)) + (cons (list 1 name) debug:call-stack))) + (let ((ans (apply function args))) + (set! debug:call-stack cs) + ans))) + (else (apply function args))))) + (else + (slib:error 'debug:trace-procedure 'unknown 'how '= how))))))) + +;;; 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 (untracef function) + (set! trace: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 *tracked-procedures* '()) +(define *stacked-procedures* '()) +(define (trace:trace-procedure how fun sym) + (define cep (current-error-port)) + (cond ((not (procedure? fun)) + (display "WARNING: not a procedure " cep) + (display sym cep) + (newline cep) + (set! *traced-procedures* (trace:deler *traced-procedures* sym)) + (set! *tracked-procedures* (trace:deler *tracked-procedures* sym)) + (set! *stacked-procedures* (trace:deler *stacked-procedures* sym)) + fun) + (else + (let ((p (assq sym (case how + ((trace) *traced-procedures*) + ((track) *tracked-procedures*) + ((stack) *stacked-procedures*))))) + (cond ((and p (eq? (cdr p) fun)) + fun) + (else + (let ((tfun (debug:trace-procedure how fun sym))) + (case how + ((trace) + (set! *traced-procedures* + (trace:adder *traced-procedures* sym tfun))) + ((track) + (set! *tracked-procedures* + (trace:adder *tracked-procedures* sym tfun))) + ((stack) + (set! *stacked-procedures* + (trace:adder *stacked-procedures* sym tfun)))) + tfun))))))) + +(define (trace:untrace-procedure fun sym) + (define finish + (lambda (p) + (cond ((not (procedure? fun)) fun) + ((eq? (cdr p) fun) (untracef fun)) + (else fun)))) + (cond ((assq sym *traced-procedures*) + => + (lambda (p) + (set! *traced-procedures* (trace:deler *traced-procedures* sym)) + (finish p))) + ((assq sym *tracked-procedures*) + => + (lambda (p) + (set! *tracked-procedures* (trace:deler *tracked-procedures* sym)) + (finish p))) + ((assq sym *stacked-procedures*) + => + (lambda (p) + (set! *stacked-procedures* (trace:deler *stacked-procedures* sym)) + (finish p))) + (else fun))) + +(define (tracef . args) (apply debug:trace-procedure 'trace args)) +(define (trackf . args) (apply debug:trace-procedure 'track args)) +(define (stackf . args) (apply debug:trace-procedure 'stack args)) + +;;;; Finally, the macros trace and untrace + +(defmacro trace xs + (if (null? xs) + `(begin (set! trace:indent 0) + ,@(map (lambda (x) + `(set! ,x (trace:trace-procedure 'trace ,x ',x))) + (map car *traced-procedures*)) + (map car *traced-procedures*)) + `(begin ,@(map (lambda (x) + `(set! ,x (trace:trace-procedure 'trace ,x ',x))) xs)))) +(defmacro track xs + (if (null? xs) + `(begin ,@(map (lambda (x) + `(set! ,x (trace:trace-procedure 'track ,x ',x))) + (map car *tracked-procedures*)) + (map car *tracked-procedures*)) + `(begin ,@(map (lambda (x) + `(set! ,x (trace:trace-procedure 'track ,x ',x))) xs)))) +(defmacro stack xs + (if (null? xs) + `(begin ,@(map (lambda (x) + `(set! ,x (trace:trace-procedure 'stack ,x ',x))) + (map car *stacked-procedures*)) + (map car *stacked-procedures*)) + `(begin ,@(map (lambda (x) + `(set! ,x (trace:trace-procedure 'stack ,x ',x))) xs)))) + +(defmacro untrace xs + (if (null? xs) + (slib:eval + `(begin ,@(map (lambda (x) + `(set! ,x (trace:untrace-procedure ,x ',x))) + (map car *traced-procedures*)) + '',(map car *traced-procedures*))) + `(begin ,@(map (lambda (x) + `(set! ,x (trace:untrace-procedure ,x ',x))) xs)))) + +(defmacro untrack xs + (if (null? xs) + (slib:eval + `(begin ,@(map (lambda (x) + `(set! ,x (track:untrack-procedure ,x ',x))) + (map car *tracked-procedures*)) + '',(map car *tracked-procedures*))) + `(begin ,@(map (lambda (x) + `(set! ,x (track:untrack-procedure ,x ',x))) xs)))) + +(defmacro unstack xs + (if (null? xs) + (slib:eval + `(begin ,@(map (lambda (x) + `(set! ,x (stack:unstack-procedure ,x ',x))) + (map car *stacked-procedures*)) + '',(map car *stacked-procedures*))) + `(begin ,@(map (lambda (x) + `(set! ,x (stack:unstack-procedure ,x ',x))) xs)))) diff --git a/module/slib/tree.scm b/module/slib/tree.scm new file mode 100644 index 000000000..f400d1b15 --- /dev/null +++ b/module/slib/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/module/slib/trnscrpt.scm b/module/slib/trnscrpt.scm new file mode 100644 index 000000000..45d884e92 --- /dev/null +++ b/module/slib/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/module/slib/tsort.scm b/module/slib/tsort.scm new file mode 100644 index 000000000..9371f3cbd --- /dev/null +++ b/module/slib/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/module/slib/tzfile.scm b/module/slib/tzfile.scm new file mode 100644 index 000000000..ca538299f --- /dev/null +++ b/module/slib/tzfile.scm @@ -0,0 +1,138 @@ +; "tzfile.scm", Read sysV style (binary) timezone file. +; Copyright (c) 1997 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 'byte) + +(define (tzfile:read-long port) + (let ((hibyte (read-byte port))) + (do ((idx 3 (+ -1 idx)) + (val (if (> hibyte 127) (+ #x-100 hibyte) hibyte) + (+ (ash val 8) (read-byte port)))) + ((zero? idx) val)))) +(define (tzfile:read-longs len port) + (define ra (make-vector len 0)) + (do ((idx 0 (+ 1 idx))) + ((>= idx len) ra) + (vector-set! ra idx (tzfile:read-long port)))) + +(define (tzfile:read-bool port) + (let ((c (read-char port))) + (if (eof-object? c) c (if (zero? (char->integer c)) #f #t)))) + +(define (tzfile:read path) + (define null (integer->char 0)) + (call-with-input-file path + (lambda (port) + (do ((idx 0 (+ 1 idx))) ;reserved. + ((>= idx 20)) + (read-char port)) + (let* ((ttisgmtcnt (tzfile:read-long port)) + (ttisstdcnt (tzfile:read-long port)) + (leapcnt (tzfile:read-long port)) + (timecnt (tzfile:read-long port)) + (typecnt (tzfile:read-long port)) + (charcnt (tzfile:read-long port)) + (transition-times (tzfile:read-longs timecnt port)) + (transition-types + (do ((ra (make-vector timecnt 0)) + (idx 0 (+ 1 idx))) + ((>= idx timecnt) ra) + (vector-set! ra idx (read-byte port)))) + ;;(printf " typecnt = %d\n" typecnt) + (mode-table (do ((tt (make-vector typecnt #f)) + (idx 0 (+ 1 idx))) + ((>= idx typecnt) tt) + (let* ((gmt-offset (tzfile:read-long port)) + (isdst (tzfile:read-bool port)) + (abbrev-index (read-byte port))) + (vector-set! tt idx + (vector abbrev-index gmt-offset + isdst #f #f))))) + ;;(printf " %d bytes of abbreviations:\n" charcnt) + (abbrevs (do ((ra (make-bytes charcnt 0)) + (idx 0 (+ 1 idx))) + ((>= idx charcnt) ra) + (string-set! ra idx (read-char port)))) + (leap-seconds (tzfile:read-longs (* 2 leapcnt) port))) + (cond ((not (or (eqv? 0 ttisstdcnt) (eqv? typecnt ttisstdcnt))) + (slib:warn 'tzfile:read "format error" ttisstdcnt typecnt))) + (cond ((not (or (eqv? 0 ttisgmtcnt) (eqv? typecnt ttisgmtcnt))) + (slib:warn 'tzfile:read "format error" ttisgmtcnt typecnt))) + ;;(printf " reading %d transition attributes\n" ttisstdcnt) + (do ((idx 0 (+ 1 idx))) + ((>= idx ttisstdcnt)) + (vector-set! (vector-ref mode-table idx) 3 (tzfile:read-bool port))) + ;;(printf " reading %d transition attributes\n" ttisgmtcnt) + (do ((idx 0 (+ 1 idx))) + ((>= idx ttisgmtcnt)) + (vector-set! (vector-ref mode-table idx) 4 (tzfile:read-bool port))) + (cond ((not (eof-object? (peek-char port))) + (slib:warn 'tzfile:read "bytes left at end"))) + (do ((idx 0 (+ 1 idx))) + ((>= idx ttisstdcnt)) + (let ((rec (vector-ref mode-table idx))) + (vector-set! + rec 0 (let loop ((pos (vector-ref rec 0))) + (cond ((>= pos (string-length abbrevs)) + (slib:warn 'tzfile:read "format error" abbrevs) #f) + ((char=? null (string-ref abbrevs pos)) + (substring abbrevs (vector-ref rec 0) pos)) + (else (loop (+ 1 pos)))))))) + (list path mode-table leap-seconds transition-times transition-types) + )))) + +(define (tzfile:transition-index time zone) + (and zone + (apply + (lambda (path mode-table leap-seconds transition-times transition-types) + (let ((ntrns (vector-length transition-times))) + (if (zero? ntrns) -1 + (let loop ((lidx (ash (+ 1 ntrns) -1)) + (jmp (ash (+ 1 ntrns) -2))) + (let* ((idx (max 0 (min lidx (+ -1 ntrns)))) + (idx-time (vector-ref transition-times idx))) + (cond ((<= jmp 0) + (+ idx (if (>= time idx-time) 0 -1))) + ((= time idx-time) idx) + ((and (zero? idx) (< time idx-time)) -1) + ((and (not (= idx lidx)) (not (< time idx-time))) idx) + (else + (loop ((if (< time idx-time) - +) idx jmp) + (if (= 1 jmp) 0 (ash (+ 1 jmp) -1)))))))))) + (cdr (vector->list zone))))) + +(define (tzfile:get-std-spec mode-table) + (do ((type-idx 0 (+ 1 type-idx))) + ((or (>= type-idx (vector-length mode-table)) + (not (vector-ref (vector-ref mode-table type-idx) 2))) + (if (>= type-idx (vector-length mode-table)) + (vector-ref mode-table 0) + (vector-ref mode-table type-idx))))) + +(define (tzfile:get-zone-spec time zone) + (apply + (lambda (path mode-table leap-seconds transition-times transition-types) + (let* ((trans-idx (tzfile:transition-index time zone))) + (if (zero? (vector-length transition-types)) + (vector-ref mode-table 0) + (if (negative? trans-idx) + (tzfile:get-std-spec mode-table) + (vector-ref mode-table + (vector-ref transition-types trans-idx)))))) + (cdr (vector->list zone)))) diff --git a/module/slib/umbscheme.init b/module/slib/umbscheme.init new file mode 100644 index 000000000..aa827ba7d --- /dev/null +++ b/module/slib/umbscheme.init @@ -0,0 +1,273 @@ +;;; "umbscheme.init" Initialization for SLIB for umb-scheme -*-scheme-*- +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. + +; MODIFIED BY Bill Campbell for UMB Scheme. + +; Further modified by Radey Shouman, for inclusion in SLIB. + +;;; (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) 'umb-scheme) + +;;; (scheme-implementation-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) + "ftp://ftp.cs.umb.edu:/pub/scheme/") + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "3.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) + (case (software-type) + ((UNIX) "/usr/lib/umb-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/lib/umb-scheme/slib/") + ((VMS) "lib$scheme:") + ((MS-DOS) "C:\\SLIB\\") + (else ""))))) + (lambda () library-path))) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define (home-vicinity) "") + +;;; *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) +(define file-exists? + (case (software-type) + ((UNIX) + (lambda (f) + (zero? (system (string-append "test -r " f))))) + (else + (lambda (f) #f)))) + +;;; (DELETE-FILE <string>) +;;(define (delete-file f) #f) +(define delete-file + (case (software-type) + ((UNIX) + (lambda (f) + (zero? (system (string-append "rm " f))))) + (else + (lambda (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. + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; 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 #x08000) + +;;; 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 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) + +(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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;;; define an error procedure for the library +(define (slib:error . args) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (apply error args)) + +;;; 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/module/slib/uri.scm b/module/slib/uri.scm new file mode 100644 index 000000000..d46c3ee79 --- /dev/null +++ b/module/slib/uri.scm @@ -0,0 +1,318 @@ +;;; "uri.scm" Construct and decode Uniform Resource Identifiers. -*-scheme-*- +; Copyright 1997, 1998, 2000, 2001 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 'coerce) +(require 'printf) +(require 'string-case) +(require 'string-search) +(require 'common-list-functions) + +;;@code{(require 'uri)} +;; +;;@noindent Implements @dfn{Uniform Resource Identifiers} (URI) as +;;described in RFC 2396. + +;;@args +;;@args fragment +;;@args query fragment +;;@args path query fragment +;;@args authority path query fragment +;;@args scheme authority path query fragment +;; +;;Returns a Uniform Resource Identifier string from component arguments. +(define (make-uri . args) + (define nargs (length args)) + (set! args (reverse args)) + (let ((fragment (if (>= nargs 1) (car args) #f)) + (query (if (>= nargs 2) (cadr args) #f)) + (path (if (>= nargs 3) (caddr args) #f)) + (authority (if (>= nargs 4) (cadddr args) #f)) + (scheme (if (>= nargs 5) (list-ref args 4) #f))) + (string-append + (if scheme (sprintf #f "%s:" scheme) "") + (cond ((string? authority) + (sprintf #f "//%s" (uric:encode authority "$,;:@&=+"))) + ((list? authority) + (apply (lambda (userinfo host port) + (cond ((and userinfo port) + (sprintf #f "//%s@%s:%d" + (uric:encode userinfo "$,;:&=+") + host port)) + (userinfo + (sprintf #f "//%s@%s" + (uric:encode userinfo "$,;:&=+") + host)) + (port + (sprintf #f "//%s:%d" host port)) + (else host))) + authority)) + (else (or authority ""))) + (cond ((string? path) (uric:encode path "/$,;:@&=+")) + ((null? path) "") + ((list? path) (uri:make-path path)) + (else path)) + (if query (sprintf #f "?%s" (uric:encode query "?/$,;:@&=+")) "") + (if fragment (sprintf #f "#%s" (uric:encode fragment "?/$,;:@&=+")) "")))) + +(define (uri:make-path path) + (apply string-append + (uric:encode (car path) "$,;:@&=+") + (map (lambda (pth) (string-append "/" (uric:encode pth "$,;:@&=+"))) + (cdr path)))) + +;;@body Returns a string which defines this location in the (HTML) file +;;as @1. The hypertext @samp{<A HREF="#@1">} will link to this point. +;; +;;@example +;;(html:anchor "(section 7)") +;;@result{} +;;"<A NAME=\"(section%207)\"></A>" +;;@end example +(define (html:anchor name) + (sprintf #f "<A NAME=\"%s\"></A>" (uric:encode name "#?/:@;="))) + +;;@body Returns a string which links the @2 text to @1. +;; +;;@example +;;(html:link (make-uri "(section 7)") "section 7") +;;@result{} +;;"<A HREF=\"#(section%207)\">section 7</A>" +;;@end example +(define (html:link uri highlighted) + (sprintf #f "<A HREF=\"%s\">%s</A>" uri highlighted)) + +;;@body Returns a string specifying the @dfn{base} @1 of a document, for +;;inclusion in the HEAD of the document (@pxref{HTML, head}). +(define (html:base uri) + (sprintf #f "<BASE HREF=\"%s\">" uri)) + +;;@body Returns a string specifying the search @1 of a document, for +;;inclusion in the HEAD of the document (@pxref{HTML, head}). +(define (html:isindex prompt) + (sprintf #f "<ISINDEX PROMPT=\"%s\">" prompt)) + +;;@body Returns a list of 5 elements corresponding to the parts +;;(@var{scheme} @var{authority} @var{path} @var{query} @var{fragment}) +;;of string @1. Elements corresponding to absent parts are #f. +;; +;;The @var{path} is a list of strings. If the first string is empty, +;;then the path is absolute; otherwise relative. +;; +;;If the @var{authority} component is a +;;@dfn{Server-based Naming Authority}, then it is a list of the +;;@var{userinfo}, @var{host}, and @var{port} strings (or #f). For other +;;types of @var{authority} components the @var{authority} will be a +;;string. +;; +;;@example +;;(uri->tree "http://www.ics.uci.edu/pub/ietf/uri/#Related") +;;@result{} +;;(http "www.ics.uci.edu" ("" "pub" "ietf" "uri" "") #f "Related") +;;@end example +(define (uri->tree uri-reference . base-tree) + (define split (uri:split uri-reference)) + (apply (lambda (b-scheme b-authority b-path b-query b-fragment) + (apply + (lambda (scheme authority path query fragment) + (define uri-empty? + (and (equal? "" path) (not scheme) (not authority) (not query))) + (list (if scheme + (string-ci->symbol scheme) + b-scheme) + (if authority + (uri:decode-authority authority) + b-authority) + (if uri-empty? + (or b-path '("")) + (uri:decode-path + (map uric:decode (uri:split-fields path #\/)) + (and (not authority) (not scheme) b-path))) + (if uri-empty? + b-query + query) + (or (and fragment (uric:decode fragment)) + (and uri-empty? b-fragment)))) + split)) + (if (or (car split) (null? base-tree) (car split)) + '(#f #f #f #f #f) + (car base-tree)))) + +(define (uri:decode-path path-list base-path) + (cond ((and (equal? "" (car path-list)) + (not (equal? '("") path-list))) + path-list) + (base-path + (let* ((cpath0 (append (butlast base-path 1) path-list)) + (cpath1 + (let remove ((l cpath0) (result '())) + (cond ((null? l) (reverse result)) + ((not (equal? "." (car l))) + (remove (cdr l) (cons (car l) result))) + ((null? (cdr l)) + (reverse (cons "" result))) + (else (remove (cdr l) result))))) + (cpath2 + (let remove ((l cpath1) (result '())) + (cond ((null? l) (reverse result)) + ((not (equal? ".." (car l))) + (remove (cdr l) (cons (car l) result))) + ((or (null? result) + (equal? "" (car result))) + (slib:warn 'uri:decode-path cpath1) + (append (reverse result) l)) + ((null? (cdr l)) + (reverse (cons "" (cdr result)))) + (else (remove (cdr l) (cdr result))))))) + cpath2)) + (else path-list))) + +(define (uri:decode-authority authority) + (define idx-at (string-index authority #\@)) + (let* ((userinfo (and idx-at (uric:decode (substring authority 0 idx-at)))) + (hostport + (if idx-at + (substring authority (+ 1 idx-at) (string-length authority)) + authority)) + (idx-: (string-index hostport #\:)) + (host (if idx-: (substring hostport 0 idx-:) hostport)) + (port (and idx-: + (substring hostport (+ 1 idx-:) (string-length hostport))))) + (if (or userinfo port) + (list userinfo host (or (string->number port) port)) + host))) + +(define uri:split-fields + (let ((cr (integer->char #xd))) + (lambda (txt chr) + (define idx (string-index txt chr)) + (if idx + (cons (substring txt 0 + (if (and (positive? idx) + (char=? cr (string-ref txt (+ -1 idx)))) + (+ -1 idx) + idx)) + (uri:split-fields (substring txt (+ 1 idx) (string-length txt)) + chr)) + (list txt))))) + +;; @body Converts a @dfn{URI} encoded @1 to a query-alist. +(define (uri:decode-query query-string) + (set! query-string (string-subst query-string " " "" "+" " ")) + (do ((lst '()) + (edx (string-index query-string #\=) + (string-index query-string #\=))) + ((not edx) lst) + (let* ((rxt (substring query-string (+ 1 edx) (string-length query-string))) + (adx (string-index rxt #\&)) + (urid (uric:decode + (substring rxt 0 (or adx (string-length rxt))))) + (name (string-ci->symbol + (uric:decode (substring query-string 0 edx))))) + (set! lst (append lst (if (equal? "" urid) + '() + (map (lambda (value) (list name value)) + (uri:split-fields urid #\newline))))) + (set! query-string + (if adx (substring rxt (+ 1 adx) (string-length rxt)) ""))))) + +(define (uri:split uri-reference) + (define len (string-length uri-reference)) + (define idx-sharp (string-index uri-reference #\#)) + (let ((fragment (and idx-sharp + (substring uri-reference (+ 1 idx-sharp) len))) + (uri (if idx-sharp + (and (not (zero? idx-sharp)) + (substring uri-reference 0 idx-sharp)) + uri-reference))) + (if uri + (let* ((len (string-length uri)) + (idx-? (string-index uri #\?)) + (query (and idx-? (substring uri (+ 1 idx-?) len))) + (front (if idx-? + (and (not (zero? idx-?)) (substring uri 0 idx-?)) + uri))) + (if front + (let* ((len (string-length front)) + (idx-: (string-index front #\:)) + (scheme (and idx-: (substring front 0 idx-:))) + (path (if idx-: + (substring front (+ 1 idx-:) len) + front))) + (cond ((eqv? 0 (substring? "//" path)) + (set! len (string-length path)) + (set! path (substring path 2 len)) + (set! len (+ -2 len)) + (let* ((idx-/ (string-index path #\/)) + (authority (substring path 0 (or idx-/ len))) + (path (if idx-/ + (substring path idx-/ len) + ""))) + (list scheme authority path query fragment))) + (else (list scheme #f path query fragment)))) + (list #f #f "" query fragment))) + (list #f #f "" #f fragment)))) + +;;@ +;;@noindent @code{uric:} prefixes indicate procedures dealing with +;;URI-components. + +;;@body Returns a copy of the string @1 in which all @dfn{unsafe} octets +;;(as defined in RFC 2396) have been @samp{%} @dfn{escaped}. +;;@code{uric:decode} decodes strings encoded by @0. +(define (uric:encode uri-component allows) + (set! uri-component (sprintf #f "%a" uri-component)) + (apply string-append + (map (lambda (chr) + (if (or (char-alphabetic? chr) + (char-numeric? chr) + (string-index "-_.!~*'()" chr) + (string-index allows chr)) + (string chr) + (let ((code (char->integer chr))) + (sprintf #f "%%%02x" code)))) + (string->list uri-component)))) + +;;@body Returns a copy of the string @1 in which each @samp{%} escaped +;;characters in @1 is replaced with the character it encodes. This +;;routine is useful for showing URI contents on error pages. +(define (uric:decode uri-component) + (define len (string-length uri-component)) + (define (sub uri) + (cond + ((string-index uri #\%) + => (lambda (idx) + (if (and (< (+ 2 idx) len) + (string->number (substring uri (+ 1 idx) (+ 2 idx)) 16) + (string->number (substring uri (+ 2 idx) (+ 3 idx)) 16)) + (string-append + (substring uri 0 idx) + (string (integer->char + (string->number + (substring uri (+ 1 idx) (+ 3 idx)) + 16))) + (sub (substring uri (+ 3 idx) (string-length uri))))))) + (else uri))) + (sub uri-component)) + +(define (uri:path->keys path-list ptypes) + (and (not (null? path-list)) + (not (equal? '("") path-list)) + (let ((path (uri:decode-path (map uric:decode path-list) #f))) + (and (= (length path) (length ptypes)) + (map coerce path ptypes))))) diff --git a/module/slib/uri.txi b/module/slib/uri.txi new file mode 100644 index 000000000..f60053c93 --- /dev/null +++ b/module/slib/uri.txi @@ -0,0 +1,94 @@ +@code{(require 'uri)} + +@noindent Implements @dfn{Uniform Resource Identifiers} (URI) as +@cindex Uniform Resource Identifiers +described in RFC 2396. + + +@defun make-uri + + +@defunx make-uri fragment + +@defunx make-uri query fragment + +@defunx make-uri path query fragment + +@defunx make-uri authority path query fragment + +@defunx make-uri scheme authority path query fragment + +Returns a Uniform Resource Identifier string from component arguments. +@end defun + +@defun html:anchor name +Returns a string which defines this location in the (HTML) file +as @var{name}. The hypertext @samp{<A HREF="#@var{name}">} will link to this point. + +@example +(html:anchor "(section 7)") +@result{} +"<A NAME=\"(section%207)\"></A>" +@end example +@end defun + +@defun html:link uri highlighted +Returns a string which links the @var{highlighted} text to @var{uri}. + +@example +(html:link (make-uri "(section 7)") "section 7") +@result{} +"<A HREF=\"#(section%207)\">section 7</A>" +@end example +@end defun + +@defun html:base uri +Returns a string specifying the @dfn{base} @var{uri} of a document, for +@cindex base +inclusion in the HEAD of the document (@pxref{HTML, head}). +@end defun + +@defun html:isindex prompt +Returns a string specifying the search @var{prompt} of a document, for +inclusion in the HEAD of the document (@pxref{HTML, head}). +@end defun + +@defun uri->tree uri-reference base-tree @dots{} +Returns a list of 5 elements corresponding to the parts +(@var{scheme} @var{authority} @var{path} @var{query} @var{fragment}) +of string @var{uri-reference}. Elements corresponding to absent parts are #f. + +The @var{path} is a list of strings. If the first string is empty, +then the path is absolute; otherwise relative. + +If the @var{authority} component is a +@dfn{Server-based Naming Authority}, then it is a list of the +@cindex Server-based Naming Authority +@var{userinfo}, @var{host}, and @var{port} strings (or #f). For other +types of @var{authority} components the @var{authority} will be a +string. + +@example +(uri->tree "http://www.ics.uci.edu/pub/ietf/uri/#Related") +@result{} +(http "www.ics.uci.edu" ("" "pub" "ietf" "uri" "") #f "Related") +@end example +@end defun + +@noindent @code{uric:} prefixes indicate procedures dealing with +URI-components. + + +@defun uric:encode uri-component allows +Returns a copy of the string @var{uri-component} in which all @dfn{unsafe} octets +@cindex unsafe +(as defined in RFC 2396) have been @samp{%} @dfn{escaped}. +@cindex escaped +@code{uric:decode} decodes strings encoded by @code{uric:encode}. +@end defun + +@defun uric:decode uri-component +Returns a copy of the string @var{uri-component} in which each @samp{%} escaped +characters in @var{uri-component} is replaced with the character it encodes. This +routine is useful for showing URI contents on error pages. +@end defun diff --git a/module/slib/values.scm b/module/slib/values.scm new file mode 100644 index 000000000..b47e0f813 --- /dev/null +++ b/module/slib/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/module/slib/version.txi b/module/slib/version.txi new file mode 100644 index 000000000..dc8cddba7 --- /dev/null +++ b/module/slib/version.txi @@ -0,0 +1,2 @@ +@set SLIBVERSION 2d1 +@set SLIBDATE March 2001 diff --git a/module/slib/vscm.init b/module/slib/vscm.init new file mode 100644 index 000000000..62b8867ad --- /dev/null +++ b/module/slib/vscm.init @@ -0,0 +1,389 @@ +;;; "vscm.init" Configuration of *features* for VSCM -*-scheme-*- +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. + +;;; 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. + +;;; 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-home-page) should return a (string) URI +;;; (Uniform Resource Identifier) for this scheme implementation's home +;;; page; or false if there isn't one. + +(define (scheme-implementation-home-page) + "http://www.cs.princeton.edu/~blume/vscm/vscm.html") + +;;; (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))) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define home-vicinity + (let ((home-path (getenv "HOME"))) + (lambda () home-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 ;proposed 2-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. + +(define (call-with-output-string proc) + (let ((outsp (open-output-string))) + (proc outsp) + (close-output-port outsp))) + +(define (call-with-input-string string proc) + (let* ((insp (open-input-string string)) + (res (proc insp))) + (close-input-port insp) + res)) + +;;; Implementation of string ports using generic ports +(define (open-input-string s) + + (let ((l (string-length s)) + (eof (call-with-values (lambda () (string-read "")) (lambda (x y) x)))) + + (define (read) + (call-with-values + (lambda () + (string-read s)) + (lambda (obj res) + (set! s res) + (set! l (string-length res)) + obj))) + + (define (read-char) + (if (zero? l) + eof + (let ((c (string-ref s 0))) + (set! s (substring s 1 l)) + (set! l (- l 1)) + c))) + + (define (peek-char) + (if (zero? l) eof (string-ref s 0))) + + (define (char-ready?) #t) + + (define (close) s) + + (open-input-generic read read-char peek-char char-ready? close))) + +(define (open-output-string) + + (let ((s "")) + + (define (write x) + (set! s (string-append s (string-write x))) + x) + + (define (display x) + (set! s (string-append s (string-display x))) + x) + + (define (write-char x) + (set! s (string-append s (string x))) + x) + + (define (newline) + (set! s (string-append s "\n")) + #f) + + (define (flush) #f) + + (define (close) s) + + (open-output-generic write display write-char newline flush close))) + +;;; "rationalize" adjunct procedures. +(define (find-ratio x e) + (let ((rat (rationalize x e))) + (list (numerator rat) (denominator rat)))) +(define (find-ratio-between x y) + (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) + +;;; 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) + +;;; 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 slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display x cep)) args)))) + +;;; define an error procedure for the library +(define (slib:error . argl) + (if (provided? 'trace) (print-call-stack (current-error-port))) + (error argl)) + +;;; 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/module/slib/withfile.scm b/module/slib/withfile.scm new file mode 100644 index 000000000..fc1351028 --- /dev/null +++ b/module/slib/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/module/slib/wttest.scm b/module/slib/wttest.scm new file mode 100644 index 000000000..cc8b5e32c --- /dev/null +++ b/module/slib/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/module/slib/wttree.scm b/module/slib/wttree.scm new file mode 100644 index 000000000..12957ba3d --- /dev/null +++ b/module/slib/wttree.scm @@ -0,0 +1,790 @@ +;; "wttree.scm" Weight balanced trees -*-Scheme-*- +;; Copyright (c) 1993-1994 Stephen Adams +;; +;; $Id: wttree.scm,v 1.1 2001/04/14 11:24:46 kei Exp $ +;; +;; 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 +;; +;; 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)) + +(define error + (case (scheme-implementation-type) + ((MITScheme) error) + (else slib:error))) +(define error:wrong-type-argument + (case (scheme-implementation-type) + ((MITScheme) error:wrong-type-argument) + (else (lambda (arg1 arg2 arg3) + (slib:error 'wrong-type-argument arg1 arg2 arg3))))) +(define error:bad-range-argument + (case (scheme-implementation-type) + ((MITScheme) error:bad-range-argument) + (else (lambda (arg1 arg2) + (slib:error 'bad-range-argument arg1 arg2))))) + +;;; +;;; 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/module/slib/yasyn.scm b/module/slib/yasyn.scm new file mode 100644 index 000000000..2b3cec094 --- /dev/null +++ b/module/slib/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) |