SUBDIRS = src doc testsuite
+DIST_SUBDIRS = src module doc testsuite
# FIXME: The `module' directory is removed from `SUBDIRS' until it can
# actually be built.
-SUBDIRS = system
-
-DISTDIRS = $(srcdir)/system $(srcdir)/language $(srcdir)/guile $(srcdir)/slib
-EXCLUDES = --exclude=CVS --exclude=*.go --exclude=*~
-
-all: slibcat
-
-clean:
- rm -f slibcat slib/*.go
-
-slibcat:
- guile -s $(top_srcdir)/src/guilec slib/*.scm
-
-dist-hook:
- $(TAR) cf - $(EXCLUDES) $(DISTDIRS) | (cd $(distdir); $(TAR) xf -)
+SUBDIRS = system language
+++ /dev/null
-;;; Guile SLIB interface
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(define-module (guile slib)
- :use-module (system vm core))
-
-(define (slib:load file)
- (let ((comp (string-append file ".go")))
- (cond ((file-exists? comp) (load-compiled comp))
- ((file-exists? file) (load file))
- (else (load (string-append file ".scm")))))
- (module-export! (current-module)
- (delq! '%module-public-interface
- (hash-fold (lambda (k v d) (cons k d)) '()
- (module-obarray (current-module))))))
-
-(let ((file (%search-load-path "slib/guile.init")))
- (if file
- (slib:load file)
- (error "Could not find slib/guile.init in" %load-path)))
-
-(define-public require require:require)
-SOURCES =
+SOURCES = translate.scm spec.scm
## FIXME: There's a bug showing up when compiling `translate.scm'.
-##
-## `spec.scm' cannot be compiled because it uses the `define-language'
-## macro which introduces an unregular object, namely the first-class
-## `<language>' procedure.
GOBJECTS = $(SOURCES:%.scm=%.go)
vmdir = $(guiledir)/language/scheme
vm_DATA = $(SOURCES) $(GOBJECTS)
CLEANFILES = $(GOBJECTS)
-MAINTAINERCLEANFILES = Makefile.in
SUFFIXES = .scm .go
%.go: %.scm
+++ /dev/null
-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
+++ /dev/null
-;;;; "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* ")")
- ))))
+++ /dev/null
-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?.
+++ /dev/null
-;;;"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")
+++ /dev/null
-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)
+++ /dev/null
-# 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)
+++ /dev/null
-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.
+++ /dev/null
-;;;"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"))
+++ /dev/null
-;;;"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))
+++ /dev/null
-;;; "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"))
+++ /dev/null
-;;;"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))
+++ /dev/null
-;;; "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)
+++ /dev/null
-;;;;"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))))))
+++ /dev/null
-;;;; "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))
+++ /dev/null
-;;; "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))
- )
+++ /dev/null
-;; "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
+++ /dev/null
-;;;; "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))))
+++ /dev/null
-;;; "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)))
+++ /dev/null
-;;;; "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)))
+++ /dev/null
-;;;; "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!)
+++ /dev/null
-;;;"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
+++ /dev/null
-;;;; "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)))
-
+++ /dev/null
-;;"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))))))
+++ /dev/null
-
-@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
+++ /dev/null
-;"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" --- ;;
+++ /dev/null
-;;"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??)
+++ /dev/null
-;;; "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))))
+++ /dev/null
-;;;"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))
+++ /dev/null
-;"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)))
+++ /dev/null
-@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
+++ /dev/null
-;;; "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)))))
+++ /dev/null
-;;; "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)
+++ /dev/null
-;;;; "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 ...)))
+++ /dev/null
-;;;"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))
+++ /dev/null
-;"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))))
+++ /dev/null
-;;;; "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)
+++ /dev/null
-; "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)))))
+++ /dev/null
-; "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))))))
+++ /dev/null
-;;;"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"))
+++ /dev/null
-; "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)
+++ /dev/null
-;;;; "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)
+++ /dev/null
-
-@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
+++ /dev/null
-;;;"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))
+++ /dev/null
-; "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))))))
+++ /dev/null
-
-@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
+++ /dev/null
-;;; "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
+++ /dev/null
-;; "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
+++ /dev/null
-;;;"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"))
+++ /dev/null
-;;"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))
+++ /dev/null
-;;; "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))))
+++ /dev/null
-;;; "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))))
-
+++ /dev/null
-;;; "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))))
+++ /dev/null
-;;; "guile.init" 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) 'Guile)
-
-;;; (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.gnu.org/software/guile/")
-
-;;; (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
- (let ((path (string-append (%package-data-dir) "/")))
- (lambda () path)))
-
-;;; (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.
- (let ((this-file (port-filename (current-load-port))))
- (substring this-file 0 (- (string-length this-file) 10))))))
- (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
-; macro-by-example
- 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
-
- abort
- array
- array-for-each
- random
- hash
- hash-table
- line-i/o
- logical
- promise
- string-case
-; syntax-case
- ))
-
-;; time
-(define difftime -)
-(define offset-time +)
-
-;; random
-(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)))
-
-;;; (OUTPUT-PORT-WIDTH <port>)
-(define (output-port-width . arg) 79)
-
-;;; (OUTPUT-PORT-HEIGHT <port>)
-(define (output-port-height . arg) 24)
-
-;;; "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)))
-
-;;; Return argument
-(define (identity x) x)
-
-;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
-(define (slib:eval x)
- (eval x (interaction-environment)))
-
-(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 t #t)
-(define nil #f)
-
-;;; Define SLIB:EXIT to be the implementation procedure to exit or
-;;; return if exitting not supported.
-(define slib:exit quit)
-
-;;; 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 f) (load-compiled-file (string-append f ".go")))
-
-;;; At this point SLIB:LOAD must be able to load SLIB files.
-
-(define slib:load slib:load)
-
-(slib:load (in-vicinity (library-vicinity) "require"))
+++ /dev/null
-; "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)
+++ /dev/null
-; "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))))
+++ /dev/null
-;;; "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)))))
+++ /dev/null
-@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
+++ /dev/null
-;;; "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))))))))))))
+++ /dev/null
-@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
+++ /dev/null
-; "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)))))
+++ /dev/null
-
-@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
+++ /dev/null
-;;;; "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)
+++ /dev/null
-;;;"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
+++ /dev/null
-;;;"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"))
+++ /dev/null
-;;;; "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)
+++ /dev/null
-;;;; "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))))
+++ /dev/null
-;;;; "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
+++ /dev/null
-;;; "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))))))))))))
+++ /dev/null
-@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
+++ /dev/null
-;"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)
+++ /dev/null
-;;;"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"))
+++ /dev/null
-;"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)
+++ /dev/null
-;;;; "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)
+++ /dev/null
-; "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)))))
+++ /dev/null
-;;; "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 -)))
+++ /dev/null
-;"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)
+++ /dev/null
-;"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 ---
+++ /dev/null
-; "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)))
+++ /dev/null
-;;; "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)))))
+++ /dev/null
-
-@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
+++ /dev/null
-;;; "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)))
+++ /dev/null
-
-@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
+++ /dev/null
-
-@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
+++ /dev/null
-;;; "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))
-
-
+++ /dev/null
-;;; "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))
+++ /dev/null
-;"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")
+++ /dev/null
-;;; "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)))))
+++ /dev/null
-;"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)
+++ /dev/null
-;;;; "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))))
+++ /dev/null
-; "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)
+++ /dev/null
-;;;; "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")))
+++ /dev/null
-;;;; "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))))
+++ /dev/null
-;;;; "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!)))
+++ /dev/null
-;;;"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)
+++ /dev/null
-;;; "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)))
+++ /dev/null
-;;;; "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)
+++ /dev/null
-;;;; "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)
+++ /dev/null
-; "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!)
+++ /dev/null
-;;; "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
- )))
+++ /dev/null
-;;;"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))))))
+++ /dev/null
-
-@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
+++ /dev/null
-;;;; "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))
+++ /dev/null
-
-@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
+++ /dev/null
-;;;; "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)))
+++ /dev/null
-;;; "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)))
- ))
+++ /dev/null
-;;; "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
+++ /dev/null
-; "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)
- ))
+++ /dev/null
-; "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)))))
+++ /dev/null
-;;; "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))))
+++ /dev/null
-;;;; 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))))
+++ /dev/null
-;;;"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))
+++ /dev/null
-;"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 >=? >=)
+++ /dev/null
-;"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)))
+++ /dev/null
-;"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))))))))))
+++ /dev/null
-;;; "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)))))))
+++ /dev/null
-;;; "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)
+++ /dev/null
-;;; "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)
+++ /dev/null
-;;; "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))))))
-
+++ /dev/null
-;;;;"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)))
+++ /dev/null
-;;; "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)))
+++ /dev/null
-;;; "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
+++ /dev/null
-;;;"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"))
+++ /dev/null
-;;; "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))
+++ /dev/null
-
-@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.
+++ /dev/null
-;"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"))
+++ /dev/null
-;"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)
+++ /dev/null
-;;;"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)
+++ /dev/null
-;;; "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"))
+++ /dev/null
-;;"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)
+++ /dev/null
-;"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)))))))
+++ /dev/null
-;;;; "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*)
+++ /dev/null
-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.
-
-\1f
-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::
-
-\1f
-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::
-
-\1f
-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
-
-\1f
-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'.
-
-\1f
-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")
- )
-
-\1f
-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'.
-
-\1f
-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
-
-\1f
-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*.
-
-\1f
-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.
-
-\1f
-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")
- ...
-
-\1f
-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.
-
-\1f
-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 '())
-
-\1f
-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'.
-
-\1f
-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.
-
-\1f
-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
-
-\1f
-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.
-
-\1f
-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'.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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
-
-\1f
-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
-
-\1f
-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::
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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::
-
-\1f
-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.
-
-
-\1f
-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.
-
-\1f
-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)'.
-
-\1f
-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 `%%'.
-
-\1f
-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.
-
-\1f
-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
-
-\1f
-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"
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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" "-?"
-
-\1f
-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"
-
-\1f
-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
-
-\1f
-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)))
-
-\1f
-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.
-
-\1f
-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. |
- |
-\1f
-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. |
-
-\1f
-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
-
-\1f
-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)
-
-\1f
-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.
-
-\1f
-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")
-
-\1f
-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)'.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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'.
-
-\1f
-File: slib.info, Node: Vector Graphics, Next: Schmooz, Prev: Time and Date, Up: Textual Conversion Packages
-
-Vector Graphics
-===============
-
-* Menu:
-
-* Tektronix Graphics Support::
-
-\1f
-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
-
-\1f
-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.
-
-\1f
-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
-
-\1f
-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
-
-\1f
-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.
-
-\1f
-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) <)'.
-
-\1f
-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.
-
-\1f
-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)
-
-\1f
-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 |
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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
-
-\1f
-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)))
-
-\1f
-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
-
-\1f
-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
-
-\1f
-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'.
-
-\1f
-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
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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>
-
-\1f
-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.
-
-\1f
-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. |
- |
-\1f
-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.
-
-\1f
-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.
-
-
-\1f
-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::
-
-\1f
-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))
-
-\1f
-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.
-
-\1f
-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))
-
-\1f
-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))
-
-\1f
-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::
-
-\1f
-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
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-
-\1f
-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'.
-
-
-\1f
-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)
- )
- ) ) )
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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")
-
-\1f
-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
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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) ...)
-
-\1f
-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. |
-
-\1f
-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::
-
-\1f
-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
-
-\1f
-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)
-
-\1f
-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)
-
-\1f
-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.
-
-\1f
-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
- |
-\1f
-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
-
-\1f
-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). |
- |
-\1f
-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}"
-
-\1f
-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.
-
-\1f
-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)
-
-\1f
-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). |
- |
-\1f
-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.
-
-\1f
-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 ....
-
-\1f
-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'.
-
-\1f
-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::).
-
-\1f
-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 |
- |
-\1f
-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
-
-\1f
-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.
-
-\1f
-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'.
-
-\1f
-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 `?'.
-
-\1f
-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
-
-\1f
-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
-
-\1f
-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
-
-\1f
-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) |
-
-\1f
-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.).
-
-\1f
-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.
-
-\1f
-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
-
-\1f
-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.
-
-\1f
-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
-
-\1f
-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)
-
-\1f
-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.
-
-\1f
-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' ....
-
-\1f
-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))
-
-\1f
-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))
-
-\1f
-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.
-
-\1f
-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
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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.
-
-\1f
-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
-
-\1f
-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.
-
-
-\1f
-Tag Table:
-Node: Top\7f1026
-Node: The Library System\7f1740
-Node: Feature\7f2054
-Node: Requesting Features\7f3004
-Node: Library Catalogs\7f4363
-Node: Catalog Compilation\7f6815
-Node: Built-in Support\7f9624
-Node: Require\7f10255
-Node: Vicinity\7f12747
-Node: Configuration\7f15714
-Node: Input/Output\7f18655
-Node: Legacy\7f20254
-Node: System\7f21096
-Node: About this manual\7f23588
-Node: Scheme Syntax Extension Packages\7f24145
-Node: Defmacro\7f24830
-Node: R4RS Macros\7f26781
-Node: Macro by Example\7f28036
-Node: Macros That Work\7f30913
-Node: Syntactic Closures\7f36971
-Node: Syntax-Case Macros\7f54405
-Node: Fluid-Let\7f58531
-Node: Yasos\7f59472
-Node: Yasos terms\7f60265
-Node: Yasos interface\7f61289
-Node: Setters\7f63364
-Node: Yasos examples\7f66005
-Node: Textual Conversion Packages\7f68999
-Node: Precedence Parsing\7f69697
-Node: Precedence Parsing Overview\7f70360
-Ref: Precedence Parsing Overview-Footnote-1\7f72358
-Node: Ruleset Definition and Use\7f72561
-Node: Token definition\7f74942
-Node: Nud and Led Definition\7f77211
-Node: Grammar Rule Definition\7f79660
-Node: Format\7f87234
-Node: Format Interface\7f87482
-Node: Format Specification\7f89219
-Node: Standard Formatted I/O\7f99349
-Node: Standard Formatted Output\7f99915
-Node: Standard Formatted Input\7f109182
-Node: Programs and Arguments\7f115842
-Node: Getopt\7f116342
-Node: Command Line\7f122184
-Node: Parameter lists\7f125373
-Node: Getopt Parameter lists\7f129358
-Node: Filenames\7f133527
-Node: Batch\7f136757
-Node: HTML\7f144550
-Node: HTML Tables\7f155838
-Node: HTTP and CGI\7f166135
-Node: URI\7f171452
-Node: Printing Scheme\7f177162
-Node: Generic-Write\7f177550
-Node: Object-To-String\7f178953
-Node: Pretty-Print\7f179357
-Node: Time and Date\7f184343
-Node: Time Zone\7f185370
-Node: Posix Time\7f189931
-Node: Common-Lisp Time\7f192067
-Node: Vector Graphics\7f193646
-Node: Tektronix Graphics Support\7f193835
-Node: Schmooz\7f195209
-Node: Mathematical Packages\7f199435
-Node: Bit-Twiddling\7f200069
-Node: Modular Arithmetic\7f204660
-Node: Prime Numbers\7f206794
-Node: Random Numbers\7f208477
-Node: Fast Fourier Transform\7f213113
-Node: Cyclic Checksum\7f214031
-Node: Plotting\7f216292
-Node: Root Finding\7f219151
-Node: Minimizing\7f223138
-Ref: Minimizing-Footnote-1\7f208597
-Node: Commutative Rings\7f225178
-Node: Determinant\7f236562
-Node: Database Packages\7f237120
-Node: Base Table\7f237384
-Node: Relational Database\7f247798
-Node: Motivations\7f248582
-Node: Creating and Opening Relational Databases\7f253629
-Node: Relational Database Operations\7f256061
-Node: Table Operations\7f259258
-Node: Catalog Representation\7f267136
-Node: Unresolved Issues\7f270034
-Node: Database Utilities\7f272985
-Node: Database Reports\7f289598
-Node: Database Browser\7f292352
-Node: Weight-Balanced Trees\7f293413
-Node: Construction of Weight-Balanced Trees\7f297284
-Node: Basic Operations on Weight-Balanced Trees\7f300734
-Node: Advanced Operations on Weight-Balanced Trees\7f303699
-Node: Indexing Operations on Weight-Balanced Trees\7f309721
-Node: Other Packages\7f313635
-Node: Data Structures\7f314034
-Node: Arrays\7f314790
-Node: Array Mapping\7f317744
-Node: Association Lists\7f319661
-Node: Byte\7f321912
-Node: Portable Image Files\7f324152
-Node: Collections\7f325699
-Node: Dynamic Data Type\7f331817
-Node: Hash Tables\7f333078
-Node: Hashing\7f335195
-Node: Object\7f339989
-Node: Priority Queues\7f348225
-Node: Queues\7f349068
-Node: Records\7f350194
-Node: Structures\7f353705
-Node: Procedures\7f355005
-Node: Common List Functions\7f355852
-Node: List construction\7f356276
-Node: Lists as sets\7f357939
-Node: Lists as sequences\7f365060
-Node: Destructive list operations\7f370366
-Node: Non-List functions\7f373029
-Node: Tree Operations\7f374174
-Node: Type Coercion\7f375796
-Node: Chapter Ordering\7f377022
-Node: Sorting\7f378719
-Node: Topological Sort\7f384496
-Node: String-Case\7f386183
-Node: String Ports\7f387284
-Node: String Search\7f388048
-Node: Line I/O\7f390415
-Node: Multi-Processing\7f392065
-Node: Metric Units\7f393248
-Node: Standards Support\7f408689
-Node: With-File\7f409423
-Node: Transcripts\7f409699
-Node: Rev2 Procedures\7f410020
-Node: Rev4 Optional Procedures\7f411727
-Node: Multi-argument / and -\7f412297
-Node: Multi-argument Apply\7f412948
-Node: Rationalize\7f413434
-Node: Promises\7f414876
-Node: Dynamic-Wind\7f415293
-Node: Eval\7f416547
-Node: Values\7f419884
-Node: Session Support\7f420671
-Node: Repl\7f421139
-Node: Quick Print\7f422422
-Node: Debug\7f423535
-Node: Breakpoints\7f424421
-Node: Trace\7f426444
-Node: System Interface\7f429555
-Node: Extra-SLIB Packages\7f433443
-Node: About SLIB\7f435743
-Node: Installation\7f436407
-Node: Porting\7f439635
-Ref: Porting-Footnote-1\7f413781
-Node: Coding Guidelines\7f441153
-Node: Copyrights\7f443234
-Node: Index\7f446519
-\1f
-End Tag Table
+++ /dev/null
-%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
+++ /dev/null
-\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
+++ /dev/null
-;;; "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!)
+++ /dev/null
-;"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))))))))))))
-
-
+++ /dev/null
-;; "stdio.scm" compatability stub
-
-(require 'scanf)
-(require 'printf)
-
-(define stdin (current-input-port))
-(define stdout (current-output-port))
-(define stderr (current-error-port))
+++ /dev/null
-;;; "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))))))
+++ /dev/null
-;;;;"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)))
+++ /dev/null
-;;; "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))
-
+++ /dev/null
-;;; "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))))))))
+++ /dev/null
-;"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)
+++ /dev/null
-;;; "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)))
- ...)))))))
+++ /dev/null
-#! /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.
+++ /dev/null
-;;; "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)))))
+++ /dev/null
-;;; "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)))
+++ /dev/null
-;;; "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))
+++ /dev/null
-;;; "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
+++ /dev/null
-;"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))
+++ /dev/null
-;"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))
+++ /dev/null
-;;;; "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)
+++ /dev/null
-;;;; "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))))
+++ /dev/null
-;;"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)
+++ /dev/null
-; "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)))))
+++ /dev/null
-;;; "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)
+++ /dev/null
-; "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))))
+++ /dev/null
-;;; "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"))
+++ /dev/null
-;;; "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)))))
+++ /dev/null
-@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
+++ /dev/null
-;"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))))))
+++ /dev/null
-@set SLIBVERSION 2d1
-@set SLIBDATE March 2001
+++ /dev/null
-;;; "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"))
+++ /dev/null
-; "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))))))
+++ /dev/null
-;; "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:
+++ /dev/null
-;; "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:
+++ /dev/null
-;;"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)
-SUBDIRS = vm
+SUBDIRS = base il vm repl
-SOURCES = compile.scm language.scm pmatch.scm
-## syntax.scm
+SOURCES = syntax.scm compile.scm language.scm pmatch.scm
GOBJECTS = $(SOURCES:%.scm=%.go)
vmdir = $(guiledir)/system/vm
vm_DATA = $(SOURCES) $(GOBJECTS)
CLEANFILES = $(GOBJECTS)
-MAINTAINERCLEANFILES = Makefile.in
SUFFIXES = .scm .go
%.go: %.scm
-SOURCES = glil.scm macros.scm
+SOURCES = glil.scm macros.scm ghil.scm compile.scm
## FIXME: There's a bug showing up when compiling `ghil.scm' and
## `compile.scm'!
GOBJECTS = $(SOURCES:%.scm=%.go)
vm_DATA = $(SOURCES) $(GOBJECTS)
CLEANFILES = $(GOBJECTS)
-MAINTAINERCLEANFILES = Makefile.in
SUFFIXES = .scm .go
%.go: %.scm
-SOURCES = repl.scm common.scm command.scm
-##describe.scm
+SOURCES = repl.scm common.scm command.scm describe.scm
GOBJECTS = $(SOURCES:%.scm=%.go)
vmdir = $(guiledir)/system/repl
vm_DATA = $(SOURCES) $(GOBJECTS)
CLEANFILES = $(GOBJECTS)
-MAINTAINERCLEANFILES = Makefile.in
SUFFIXES = .scm .go
%.go: %.scm
vm_DATA = $(SOURCES) $(GOBJECTS)
CLEANFILES = $(GOBJECTS)
-MAINTAINERCLEANFILES = Makefile.in
SUFFIXES = .scm .go
%.go: %.scm
HCoop / bpt / guile.git / commitdiff