summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJames LewisMoss <dres@debian.org>2001-07-27 23:45:29 -0400
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commitf559c149c83da84d0b1c285f0298c84aec564af9 (patch)
treef1c91bcb9bb5e6dad87b643127c3f878d80d89ee
parentc394920caedf3dac1981bb6b10eeb47fd6e4bb21 (diff)
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-debian/2d2-1.tar.gz
slib-debian/2d2-1.zip
Import Debian changes 2d2-1debian/2d2-1
slib (2d2-1) unstable; urgency=low * New upstream version * Revert back to free. Is now so. slib (2d1-1) unstable; urgency=low * New upstream version. * Move to non-free. FSF pointed out license doesn't allow modified versions to be distributed. * Get a complete list of copyrights that apply to the source into copyright file. * Remove setup for guile 1.3. * Remove postrm. Just calling install-info (lintian) Move install-info call to prerm since doc-base doesn't do install-info. slib (2c9-3) unstable; urgency=low * Change info location to section "The Algorithmic Language Scheme" to match up with where guile puts it's files. * Postinst is running slibconfig now. (Closes: #75891) slib (2c9-2) unstable; urgency=low * Stop installing slibconfig (for guile). * In postinst if /usr/sbin/slibconnfig exists call it (Close: #75843 #75891). slib (2c9-1) unstable; urgency=low * New upstream (Closes: #74760) * replace string-index with strsrch:string-index in http-cgi.scm. * Add doc-base support (Closes: #31163)
-rw-r--r--ANNOUNCE114
-rw-r--r--Bev2slib.scm6
-rw-r--r--COPYING37
-rw-r--r--ChangeLog675
-rw-r--r--DrScheme.init6
-rw-r--r--FAQ10
-rw-r--r--Makefile195
-rw-r--r--README172
-rw-r--r--RScheme.init92
-rw-r--r--STk.init92
-rw-r--r--Template.scm116
-rw-r--r--alist.scm6
-rw-r--r--alistab.scm23
-rw-r--r--array.scm471
-rw-r--r--array.txi111
-rw-r--r--arraymap.scm6
-rw-r--r--batch.scm6
-rw-r--r--bigloo.init178
-rw-r--r--break.scm24
-rw-r--r--chap.scm8
-rw-r--r--charplot.scm65
-rw-r--r--chez.init100
-rw-r--r--cltime.scm8
-rw-r--r--coerce.scm107
-rw-r--r--coerce.txi12
-rw-r--r--comlist.scm375
-rw-r--r--comparse.scm6
-rw-r--r--cring.scm6
-rw-r--r--db2html.scm463
-rw-r--r--db2html.txi185
-rw-r--r--dbrowse.scm6
-rw-r--r--dbutil.scm74
-rw-r--r--debian/changelog49
-rw-r--r--debian/control2
-rw-r--r--debian/copyright557
-rw-r--r--debian/doc-base15
-rw-r--r--debian/postinst20
-rw-r--r--debian/postrm5
-rw-r--r--debian/prerm8
-rwxr-xr-xdebian/rules10
-rw-r--r--debug.scm70
-rw-r--r--defmacex.scm10
-rw-r--r--differ.scm222
-rw-r--r--differ.txi95
-rw-r--r--dwindtst.scm6
-rw-r--r--dynwind.scm6
-rw-r--r--elk.init89
-rw-r--r--eval.scm6
-rw-r--r--factor.scm8
-rw-r--r--factor.txi69
-rw-r--r--fft.scm6
-rw-r--r--fluidlet.scm6
-rw-r--r--fmtdoc.txi2
-rw-r--r--format.scm1
-rw-r--r--gambit.init33
-rw-r--r--genwrite.scm32
-rw-r--r--getopt.scm6
-rw-r--r--getparam.scm201
-rw-r--r--glob.scm9
-rw-r--r--guile.init4
-rw-r--r--hash.scm6
-rw-r--r--hashtab.scm6
-rw-r--r--htmlform.scm1128
-rw-r--r--htmlform.txi343
-rw-r--r--http-cgi.scm440
-rw-r--r--http-cgi.txi112
-rw-r--r--lineio.scm8
-rw-r--r--lineio.txi24
-rw-r--r--logical.scm8
-rw-r--r--macscheme.init86
-rw-r--r--makcrc.scm49
-rw-r--r--mbe.scm6
-rw-r--r--minimize.scm114
-rw-r--r--minimize.txi48
-rw-r--r--mitcomp.pat1466
-rw-r--r--mitscheme.init104
-rw-r--r--mklibcat.scm25
-rw-r--r--modular.scm8
-rw-r--r--mulapply.scm6
-rw-r--r--mularg.scm2
-rw-r--r--nclients.scm20
-rw-r--r--nclients.txi26
-rw-r--r--obj2str.scm23
-rw-r--r--obj2str.txi8
-rw-r--r--object.scm4
-rw-r--r--paramlst.scm33
-rw-r--r--plottest.scm6
-rw-r--r--pnm.scm213
-rw-r--r--pp.scm15
-rw-r--r--ppfile.scm6
-rw-r--r--prec.scm10
-rw-r--r--printf.scm366
-rw-r--r--priorque.scm8
-rw-r--r--process.scm8
-rw-r--r--pscheme.init458
-rw-r--r--psxtime.scm8
-rw-r--r--qp.scm8
-rw-r--r--r4rsyn.scm5
-rw-r--r--randinex.scm28
-rw-r--r--randinex.txi32
-rw-r--r--random.scm10
-rw-r--r--random.txi14
-rw-r--r--ratize.scm26
-rw-r--r--rdms.scm41
-rw-r--r--recobj.scm4
-rw-r--r--record.scm59
-rw-r--r--repl.scm6
-rw-r--r--report.scm6
-rw-r--r--require.scm55
-rw-r--r--root.scm6
-rw-r--r--s48-0_57.init381
-rw-r--r--sc2.scm8
-rw-r--r--sc4opt.scm8
-rw-r--r--sc4sc3.scm6
-rw-r--r--scanf.scm32
-rw-r--r--scheme2c.init108
-rw-r--r--scheme48.init216
-rw-r--r--schmooz.scm56
-rw-r--r--schmooz.texi104
-rw-r--r--scmacro.scm6
-rw-r--r--scmactst.scm160
-rw-r--r--scsh.init30
-rw-r--r--simetrix.scm246
-rw-r--r--slib.info3915
-rw-r--r--slib.spec97
-rw-r--r--slib.texi1926
-rw-r--r--srcdir.mk2
-rw-r--r--srfi-1.scm253
-rw-r--r--srfi-1.txi178
-rw-r--r--srfi.scm83
-rw-r--r--srfi.txi42
-rw-r--r--strcase.scm22
-rw-r--r--strport.scm6
-rw-r--r--struct.scm165
-rw-r--r--structst.scm37
-rwxr-xr-x[-rw-r--r--]syncase.sh0
-rw-r--r--synchk.scm5
-rw-r--r--synclo.scm5
-rw-r--r--synrul.scm5
-rw-r--r--t3.init98
-rw-r--r--tek40.scm6
-rw-r--r--tek41.scm6
-rw-r--r--timezone.scm8
-rw-r--r--trace.scm254
-rw-r--r--tree.scm53
-rw-r--r--trnscrpt.scm6
-rw-r--r--tzfile.scm6
-rw-r--r--umbscheme.init30
-rw-r--r--uri.scm319
-rw-r--r--uri.txi95
-rw-r--r--version.txi4
-rw-r--r--vscm.init84
-rw-r--r--withfile.scm8
-rw-r--r--wttest.scm66
-rw-r--r--wttree.scm90
-rw-r--r--yasyn.scm6
156 files changed, 12823 insertions, 7221 deletions
diff --git a/ANNOUNCE b/ANNOUNCE
index 3f94e63..6070290 100644
--- a/ANNOUNCE
+++ b/ANNOUNCE
@@ -1,42 +1,95 @@
-This message announces the availability of Scheme Library release slib2c7.
-
-New in slib2c7:
-
- * charplot.scm (charplot:number->string): printf %g gets rid of
- microscopic fractions.
- * printf.scm (%g): Make precision threshold work for both
- fractions and integers.
- * nclients.scm (browse-url-netscape): Try running netscape in
- background.
- * batch.scm (write-batch-line): Added slib:warn.
- * paramlst.scm (check-parameters): Improved warning.
- * 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.
- * glob.scm (replace-suffix): Now works.
- * slib.texi: Put description and URL into slib_toc.html.
+This message announces the availability of Scheme Library release slib2d2.
+
+New in slib2d2:
+
+ * s48-0_57.init: Added.
+ * array.scm (make-shared-array): Fixed offset.
+ * record.scm: Changed identifiers containing VECTOR to VECT or VCT
+ (but no help for scheme48-0.57).
+ * slib.texi (Collections, Lists as sets, Multi-argument / and -,
+ Multi-argument Apply): Improved procedure templates.
+ * comlist.scm: Replaced single-letter identifier names to improve
+ readability.
+ * slib.texi (Lists as sequences): Updated examples per change to
+ comlist.scm.
+ * comlist.scm (comlist:union, comlist:intersection,
+ comlist:set-difference, comlist:remove-if, comlist:remove-if-not,
+ comlist:remove-duplicates): Earlier tail-recursion enhancements
+ changed the element order; which broke things. Order restored.
+ * array.scm: Rewritten to sidestep license issues.
+ (array=?): Added.
+ * slib.texi (Arrays): Documentation integrated with array.scm.
+ * tree.scm (tree:subst): Rewritten; takes optional equality
+ predicate argument.
+ * Makefile (docfiles): Added "COPYING".
+ * mitcomp.pat: Unmaintained; removed.
+ * RScheme.init: Put in the public domain.
+ * Makefile (slib48): Simplified: scheme48 < scheme48.init
+ * scheme48.init (slib-primitives): Pipe into scheme48, not load.
+ Scheme48-0.45 the only version which runs jacal successfully.
+ * scmactst.scm: Removed for lack of license.
+ * struct.scm, structst.scm: Removed. struct.scm lacks license.
+ * scheme48.init (atan): Added workaround.
+ * Makefile (slib48-0.55): Makes slib48, but fluid-let broken.
+ * format.scm (mutliarg/and-): Requires.
+ * mularg.scm (two-arg:/, two-arg:-): Added.
+ * scheme48.init (*features*): Doesn't support multiarg/and-.
+ * Makefile (slib48-0.45): Added ",load-package floatnums".
+ * slib.texi (Installation): Added specific instructions for
+ DrScheme, MIT-Scheme, and Guile.
+ * guile.init: Added.
+ * require.scm (program-vicinity): Improved error message.
+ * slib.texi (Installation): Explicit instructions for MzScheme.
+ * Makefile (pdf): Added target for creating $(htmldir)slib.pdf.
+ * slib.texi (Installation): Expanded instructions.
+ * bigloo.init, RScheme.init, STk.init (*features*): Provide srfi.
+ * Template.scm, *.init (*features*): Put into consistent form.
+ * require.scm (srfi): Detect presence of srfi-0 through srfi-30.
+ * srfi-1.scm: Added.
+ * comlist.scm (comlist:remove): Returns don't disturb order.
+ * array.scm: Generalized so strings and vectors are arrays.
+ * slib.texi (Standard Formatted Output): %b was missing.
+ * slib.texi (Sorting and Searching): Section split from
+ "Procedures".
+ * differ.scm (diff:longest-common-subsequence): Added.
+ (diff:longest-common-subsequence, diff:edits, diff:edit-length):
+ Optional third argument is equality predicate.
+ * differ.scm: An O(NP) Sequence Comparison Algorithm.
+ * srfi.scm (cond-expand): Added.
+ * wttree.scm (error:error): Replaces error.
+ * dbutil.scm (make-defaulter): number defaults to 0.
+ * Makefile (rpm): Fixed dependencies.
+
+From Jacques Mequin <jmequin@tif.ti.com>
+ * gambit.init: (set-case-conversion! #t)
+ * scheme48.init (defmacro): Defmacro in terms of define-syntax
+ using defmacro:expand*.
+
+From Wade Humeniuk <humeniuw@cadvision.com>
+ * yasyn.scm, object.scm, recobj.scm: Placed in public domain.
SLIB is a portable Scheme library providing compatibiliy and utility
functions for all standard Scheme implementations.
-SLIB includes initialization files for Bigloo, Chez, ELK, GAMBIT,
-MacScheme, MITScheme, PocketScheme, RScheme Scheme->C, Scheme48, SCM,
-SCSH, T3.1, UMB-Scheme, and VSCM.
+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 standards for the library. Documentation of each library
+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
+ http://swissnet.ai.mit.edu/~jaffer/SLIB.html
-SLIB source is available from:
- http://swissnet.ai.mit.edu/ftpdir/scm/slib2c7.zip
- ftp.gnu.org:pub/gnu/jacal/slib2c7.zip (FTP instructions follow)
+SLIB is available from:
+ http://swissnet.ai.mit.edu/ftpdir/scm/slib2d2.zip
+ http://swissnet.ai.mit.edu/ftpdir/scm/slib-2d2-1.noarch.rpm
+ swissnet.ai.mit.edu:/pub/scm/slib2d2.zip
+ swissnet.ai.mit.edu:/pub/scm/slib-2d2-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
- ftp.gnu.org:pub/gnu/jacal/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/
@@ -44,10 +97,3 @@ SCHELOG is an embedding of Prolog in Scheme+SLIB:
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
-
- -=-=-
-
- ftp ftp.gnu.org (anonymous)
- bin
- cd pub/gnu/jacal
- get slib2c5.zip
diff --git a/Bev2slib.scm b/Bev2slib.scm
index 24a7c68..8461c5c 100644
--- a/Bev2slib.scm
+++ b/Bev2slib.scm
@@ -1,9 +1,9 @@
;;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..c16d8bd
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,37 @@
+ SLIB LICENSE
+
+Each file in SLIB (over a dozen lines in length) is either in the public
+domain, or comes with a statement of terms permitting users to copy,
+modify, and redistribute it.
+
+The comments at the beginning each file (containing over a dozen lines)
+must specify its terms. For instance, the comments at the beginning of
+"Template.scm" declare that it is in the public domain:
+
+ ;;; "Template.scm" configuration template of *features* for Scheme
+ ;;; Author: Aubrey Jaffer
+ ;;;
+ ;;; This code is in the public domain.
+
+Each copyrighted file lists the names of the copyright holders and gives
+permissions to copy, modify, and redistribute the file. For instance,
+the beginning of "require.scm" states:
+
+ ;;;; Implementation of VICINITY and MODULES for Scheme
+ ;Copyright (C) 1991, 1992, 1993, 1994, 1997 Aubrey Jaffer
+ ;
+ ;Permission to copy this software, to modify it, to redistribute it,
+ ;to distribute modified versions, and to use it for any purpose is
+ ;granted, subject to the following restrictions and understandings.
+ ;
+ ;1. Any copy made of this software must include this copyright notice
+ ;in full.
+ ;
+ ;2. I have made no warrantee or representation that the operation of
+ ;this software will be error-free, and I am under no obligation to
+ ;provide any services, by way of maintenance, update, or otherwise.
+ ;
+ ;3. In conjunction with products arising from the use of this
+ ;material, there shall be no use of my name in any advertising,
+ ;promotional, or sales literature without prior written consent in
+ ;each case.
diff --git a/ChangeLog b/ChangeLog
index e56d1fa..e5f19fa 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,631 @@
-Sun Dec 5 19:54:35 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer>
+Fri Jul 27 19:54:00 EDT 2001 Aubrey Jaffer <jaffer@aubrey.jaffer>
+
+ * require.scm (*SLIB-VERSION*): Bumped from 2d1 to 2d2.
+
+2001-07-27 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * s48-0_57.init: Added.
+
+2001-07-24 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * array.scm (make-shared-array): Fixed offset.
+
+ * record.scm: Changed identifiers containing VECTOR to VECT or VCT
+ (but no help for scheme48-0.57).
+
+2001-07-18 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * slib.texi (Collections, Lists as sets, Multi-argument / and -,
+ Multi-argument Apply): Improved procedure templates.
+
+ * comlist.scm: Replaced single-letter identifier names to improve
+ readability.
+
+ * slib.texi (Lists as sequences): Updated examples per change to
+ comlist.scm.
+
+ * comlist.scm (comlist:union, comlist:intersection,
+ comlist:set-difference, comlist:remove-if, comlist:remove-if-not,
+ comlist:remove-duplicates): Earlier tail-recursion enhancements
+ changed the element order; which broke things. Order restored.
+
+2001-07-16 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * array.scm: Rewritten to sidestep license issues.
+ (array=?): Added.
+
+ * slib.texi (Arrays): Documentation integrated with array.scm.
+
+2001-06-28 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * tree.scm (tree:subst): Rewritten; takes optional equality
+ predicate argument.
+
+2001-06-21 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Makefile (docfiles): Added "COPYING".
+
+2001-06-19 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * mitcomp.pat: Unmaintained; removed.
+
+ * RScheme.init: Put in the public domain.
+
+2001-06-11 Jacques Mequin <jmequin@tif.ti.com>
+
+ * gambit.init: (set-case-conversion! #t)
+
+2001-06-07 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Makefile (slib48): Simplified: scheme48 < scheme48.init
+
+ * scheme48.init (slib-primitives): Pipe into scheme48, not load.
+ Scheme48-0.45 the only version which runs jacal successfully.
+
+2001-06-05 Jacques Mequin <jmequin@tif.ti.com>
+
+ * scheme48.init (defmacro): Defmacro in terms of define-syntax
+ using defmacro:expand*.
+
+1998-09-28 Wade Humeniuk <humeniuw@cadvision.com>
+
+ * yasyn.scm, object.scm, recobj.scm: Placed in public domain.
+
+2001-05-31 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scmactst.scm: Removed for lack of license.
+
+ * struct.scm, structst.scm: Removed. struct.scm lacks license.
+
+2001-05-29 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scheme48.init (atan): Added workaround.
+
+ * Makefile (slib48-0.55): Makes slib48, but fluid-let broken.
+
+2001-05-28 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * format.scm (mutliarg/and-): Requires.
+
+ * mularg.scm (two-arg:/, two-arg:-): Added.
+
+ * scheme48.init (*features*): Doesn't support multiarg/and-.
+
+ * Makefile (slib48-0.45): Added ",load-package floatnums".
+
+2001-05-23 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * slib.texi (Installation): Added specific instructions for
+ DrScheme, MIT-Scheme, and Guile.
+
+ * guile.init: Added.
+
+2001-05-19 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * require.scm (program-vicinity): Improved error message.
+
+ * slib.texi (Installation): Explicit instructions for MzScheme.
+
+2001-05-15 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Makefile (pdf): Added target for creating $(htmldir)slib.pdf.
+
+2001-04-26 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * slib.texi (Installation): Expanded instructions.
+
+2001-04-15 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * bigloo.init, RScheme.init, STk.init (*features*): Provide srfi.
+
+ * Template.scm, *.init (*features*): Put into consistent form.
+
+ * require.scm (srfi): Detect presence of srfi-0 through srfi-30.
+
+2001-04-12 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * srfi-1.scm: Added.
+
+ * comlist.scm (comlist:remove): Returns don't disturb order.
+
+2001-04-10 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * array.scm: Generalized so strings and vectors are arrays.
+
+ * slib.texi (Standard Formatted Output): %b was missing.
+
+2001-04-05 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * slib.texi (Sorting and Searching): Section split from
+ "Procedures".
+
+ * differ.scm (diff:longest-common-subsequence): Added.
+ (diff:longest-common-subsequence, diff:edits, diff:edit-length):
+ Optional third argument is equality predicate.
+
+2001-04-04 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * differ.scm: An O(NP) Sequence Comparison Algorithm.
+
+2001-03-29 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * srfi.scm (cond-expand): Added.
+
+2001-03-23 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * wttree.scm (error:error): Replaces error.
+
+2001-03-21 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * dbutil.scm (make-defaulter): number defaults to 0.
+
+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 <aubrey_jaffer@splashtech.com>
+1999-12-04 Aubrey Jaffer <jaffer@ai.mit.edu>
* charplot.scm (charplot:number->string): printf %g gets rid of
microscopic fractions.
@@ -10,20 +633,20 @@ Sun Dec 5 19:54:35 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer>
* printf.scm (%g): Make precision threshold work for both
fractions and integers.
-1999-12-03 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+1999-12-03 Aubrey Jaffer <jaffer@ai.mit.edu>
* nclients.scm (browse-url-netscape): Try running netscape in
background.
-1999-11-14 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+1999-11-14 Aubrey Jaffer <jaffer@ai.mit.edu>
* batch.scm (write-batch-line): Added slib:warn.
-1999-11-01 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+1999-11-01 Aubrey Jaffer <jaffer@ai.mit.edu>
* paramlst.scm (check-parameters): Improved warning.
-1999-10-31 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+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.
@@ -34,15 +657,15 @@ Sun Dec 5 19:54:35 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer>
* glob.scm (replace-suffix): Now works.
-1999-09-17 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+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@aubrey.jaffer>
+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 <aubrey_jaffer@splashtech.com>
+1999-07-08 Aubrey Jaffer <jaffer@ai.mit.edu>
* format.scm (format:string-capitalize-first): Renamed from
string-capitalize-first.
@@ -222,7 +845,7 @@ Sun Sep 12 22:45:01 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer>
* alistab.scm (open-base): Check file exists before opening it.
-1999-01-21 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+1999-01-21 Aubrey Jaffer <jaffer@ai.mit.edu>
* htmlform.scm (html:start-page): Extra arguments printed in HEAD
(for META tags).
@@ -238,11 +861,11 @@ Sun Sep 12 22:45:01 EDT 1999 Aubrey Jaffer <jaffer@aubrey.jaffer>
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@aubrey.jaffer>
+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 <aubrey_jaffer@splashtech.com>
+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.
@@ -264,13 +887,13 @@ Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer>
* random.scm (seed->random-state): added.
-1999-01-08 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+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 <aubrey_jaffer@splashtech.com>
+1999-01-07 Aubrey Jaffer <jaffer@ai.mit.edu>
* alistab.scm (supported-key-type?): number now allowed.
@@ -320,7 +943,7 @@ Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer>
* slib.texi (Copyrights): Added HTML anchor for Copying information.
(Installation): Added HTML anchor for Installation instructions.
-1998-12-02 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+1998-12-02 Aubrey Jaffer <jaffer@ai.mit.edu>
* fluidlet.scm (fluid-let): Rewritten as defmacro.
@@ -339,11 +962,11 @@ Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer>
* nclients.scm (glob-pattern?): Added.
-1998-11-24 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+1998-11-24 Aubrey Jaffer <jaffer@ai.mit.edu>
* htmlform.scm (html:href-heading): simplified.
-1998-11-16 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+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;
@@ -362,7 +985,7 @@ Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer>
* rdms.scm (make-relational-system): column-foreign-list split
into column-foreign-check-list and column-foreign-list.
-1998-11-12 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+1998-11-12 Aubrey Jaffer <jaffer@ai.mit.edu>
* lineio.scm (display-file): added. Schmoozed docs.
@@ -378,14 +1001,14 @@ Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer <jaffer@aubrey.jaffer>
if a continuation captured in the body is invoked. Now agrees
with MIT Scheme documentation.
-1998-11-11 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+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 <aubrey_jaffer@splashtech.com>
+1998-11-04 Aubrey Jaffer <jaffer@ai.mit.edu>
* comlist.scm (remove-duplicates): added.
(adjoin): memq -> memv.
@@ -408,7 +1031,7 @@ Tue Nov 3 17:47:32 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net>
caused ctime to print out things in GMT, instead of using the
local time.
-1998-10-01 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+1998-10-01 Aubrey Jaffer <jaffer@ai.mit.edu>
* factor.scm: Moved documentation to schmooz format.
(prime:prime< prime:prime>): written.
@@ -422,7 +1045,7 @@ Tue Nov 3 17:47:32 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net>
* primes.scm: removed.
-1998-09-29 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+1998-09-29 Aubrey Jaffer <jaffer@ai.mit.edu>
* paramlst.scm (check-parameters): Now generates slib:warn when
parameter is wrong type.
@@ -432,7 +1055,7 @@ Tue Nov 3 17:47:32 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net>
* batch.scm (batch:port parms): enabled warning.
-1998-09-28 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+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,
@@ -442,7 +1065,7 @@ Tue Nov 3 17:47:32 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net>
* schmooz.scm, htmlform.scm, admin.scm, glob.scm, ChangeLog:
Cleaned a bit.
-1998-09-28 Aubrey Jaffer <aubrey_jaffer@splashtech.com>
+1998-09-28 Aubrey Jaffer <jaffer@ai.mit.edu>
* slib.texi (most-positive-fixnum): fixed description.
@@ -584,7 +1207,7 @@ Tue Nov 3 17:47:32 EST 1998 Aubrey Jaffer <jaffer@scm.colorage.net>
Fri Jun 5 16:01:26 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net>
-o * require.scm (*SLIB-VERSION*): Bumped from 2c1 to 2c2.
+ * require.scm (*SLIB-VERSION*): Bumped from 2c1 to 2c2.
1998-06-04 Aubrey Jaffer <jaffer@colorage.com>
@@ -853,7 +1476,7 @@ 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@aubrey.jaffer>
+Sat Aug 23 09:32:44 EDT 1997 Aubrey Jaffer <jaffer@ai.mit.edu>
* require.scm (*SLIB-VERSION*): Bumped from 2b2 to 2b3.
diff --git a/DrScheme.init b/DrScheme.init
new file mode 100644
index 0000000..0676250
--- /dev/null
+++ b/DrScheme.init
@@ -0,0 +1,6 @@
+;;;"DrScheme.init" Initialization for SLIB for DrScheme -*-scheme-*-
+;; Friedrich Dominicus <frido@q-software-solutions.com>
+;; Newsgroups: comp.lang.scheme
+;; Date: 02 Oct 2000 09:24:57 +0200
+
+(require-library "init.ss" "slibinit")
diff --git a/FAQ b/FAQ
index 790cbc5..93f94da 100644
--- a/FAQ
+++ b/FAQ
@@ -1,4 +1,4 @@
-FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib2c7).
+FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib2d2).
Written by Aubrey Jaffer (http://swissnet.ai.mit.edu/~jaffer).
INTRODUCTION AND GENERAL INFORMATION
@@ -14,8 +14,8 @@ Scheme is a programming language in the Lisp family.
[] Which implementations has SLIB been ported to?
-SLIB is supported by Bigloo, Chez, ELK, GAMBIT, MacScheme, MITScheme,
-PocketScheme, RScheme Scheme->C, Scheme48, SCM, SCSH, T3.1,
+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?
@@ -23,7 +23,7 @@ UMB-Scheme, and VSCM.
SLIB is available via http from:
http://swissnet.ai.mit.edu/~jaffer/SLIB.html
SLIB is available via ftp from:
- ftp.gnu.org:pub/gnu/jacal/
+ swissnet.ai.mit.edu:/pub/scm/
SLIB is also included with SCM floppy disks.
@@ -48,7 +48,7 @@ Several times a year.
[] What is the latest version?
-The version as of this writing is slib2c7. The latest documentation
+The version as of this writing is slib2d2. The latest documentation
is available online at:
http://swissnet.ai.mit.edu/~jaffer/SLIB.html
diff --git a/Makefile b/Makefile
index 22ff48b..3a1d5fc 100644
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,7 @@
# Makefile for Scheme Library
-# Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 Aubrey Jaffer.
+# Author: Aubrey Jaffer
+#
+# This code is in the public domain.
SHELL = /bin/sh
intro:
@@ -10,28 +12,39 @@ intro:
@echo
-make slib.info
-srcdir=$(HOME)/slib/
+include srcdir.mk
+srcdir.mk: .. Makefile
+ echo -e "srcdir = `pwd`/\n" > srcdir.mk
+#srcdir=$(HOME)/slib/
+PREVDOCS = prevdocs/
dvidir=../dvi/
dvi: $(dvidir)slib.dvi
-$(dvidir)slib.dvi: version.txi slib.texi $(dvidir)slib.fn
+$(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
+ 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
+slib_toc.html: version.txi slib.texi htmlform.txi schmooz.texi
texi2html -split -verbose slib.texi
-slib/slib_toc.html:
- cd slib;make slib_toc.html
- cd slib;texi2html -split -verbose slib.texi
+pdf: $(htmldir)slib.pdf
+$(htmldir)slib.pdf: version.txi slib.texi $(dvidir)slib.fn schmooz.texi
+# cd $(dvidir);dvipdf slib.dvi # doesn't have links!
+ cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)slib.texi
+ mv $(dvidir)slib.pdf $(htmldir)
+xpdf: $(htmldir)slib.pdf
+ xpdf -z 3 $(htmldir)slib.pdf
html: $(htmldir)slib_toc.html
-$(htmldir)slib_toc.html: slib slib_toc.html Makefile
- hitch slib/slib_\*.html slib_\*.html $(htmldir)
+$(htmldir)slib_toc.html: slib_toc.html Makefile
+ hitch $(PREVDOCS)slib_\*.html slib_\*.html $(htmldir)
+
+rpm_prefix=/usr/src/redhat/
prefix = debian/tmp/usr
exec_prefix = $(prefix)
@@ -44,65 +57,25 @@ 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
+slib48: $(IMAGE)
+$(IMAGE): Makefile scheme48.init
+ export S48_VERSION="`echo ,exit | scheme48 | sed -n 's/Welcome to Scheme 48 //;s/ ([^)]*)[.]//;p;q'`";\
+ export S48_VICINITY="$(LIB)/";\
+ export SCHEME_LIBRARY_PATH="`pwd`/";\
+ scheme48 < scheme48.init
+install48: $(IMAGE)
$(INSTALL_DATA) $(IMAGE) $(LIB)
- (echo '#!/bin/sh'; \
+ (echo '#!/bin/sh';\
echo exec $(RUNNABLE) -i '$(LIB)/$(IMAGE)' \"\$$\@\") \
> $(bindir)/slib48
chmod +x $(bindir)/slib48
#### Stuff for maintaining SLIB below ####
-VERSION = 2c7
+VERSION = 2d2
ver = $(VERSION)
version.txi: Makefile
echo @set SLIBVERSION $(VERSION) > version.txi
@@ -112,13 +85,12 @@ scheme = scm
htmlform.txi: *.scm
$(scheme) -rschmooz -e'(schmooz "slib.texi")'
-slib$(VERSION).info: version.txi slib.texi htmlform.txi objdoc.txi
- -mv slib.info slibtemp.info
+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
- -mv slibtemp.info slib.info
-slib.info: slib$(VERSION).info
-# infobar slib/slib.info slib$(VERSION).info slib.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
@@ -133,45 +105,50 @@ $(infodir)/slib.info.gz: $(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
+ strsrch.scm prec.scm schmooz.scm differ.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 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
+ 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 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
+dfiles = defmacex.scm mbe.scm srfi.scm
+srfiles = srfi-1.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
+ 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 getparam.scm glob.scm fft.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 objdoc.txi fmtdoc.txi \
- ChangeLog
+docfiles = ANNOUNCE README COPYING 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
-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 umbscheme.init
-tfiles = plottest.scm formatst.scm macrotst.scm scmactst.scm \
- dwindtst.scm structst.scm
+ Bev2slib.scm slib.spec
+ifiles = bigloo.init chez.init elk.init macscheme.init mitscheme.init \
+ scheme2c.init scheme48.init s48-0_57.init gambit.init t3.init \
+ vscm.init scm.init scsh.init pscheme.init STk.init \
+ RScheme.init DrScheme.init umbscheme.init guile.init
+tfiles = plottest.scm formatst.scm macrotst.scm dwindtst.scm
sfiles = $(ffiles) $(lfiles) $(revfiles) $(afiles) $(scfiles) $(efiles) \
- $(rfiles) $(gfiles) $(scafiles) $(dfiles)
+ $(rfiles) $(gfiles) $(scafiles) $(dfiles) $(srfiles)
allfiles = $(docfiles) $(mfiles) $(ifiles) $(sfiles) $(tfiles) $(bfiles)
makedev = make -f $(HOME)/makefile.dev
CHPAT=$(HOME)/bin/chpat
-RSYNC=rsync -v --rsync-path bin/rsync
+RSYNC=rsync -avessh
dest = $(HOME)/dist/
temp/slib: $(allfiles)
-rm -rf temp
@@ -185,18 +162,27 @@ infotemp/slib: slib.info
mkdir infotemp/slib
ln slib.info slib.info-* infotemp/slib
#For change-barred HTML.
-slib:
- unzip -a $(dest)slib[0-9]*.zip
+prevdocs: srcdir.mk Makefile
+ cd prevdocs; unzip -a $(dest)slib*.zip
+ rm prevdocs/slib/slib.info
+ cd prevdocs/slib; make slib.info; make slib_toc.html
+ cd prevdocs; mv -f slib/slib.info slib/*.html ./
+ rm -rf prevdocs/slib
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
- cp $(srcdir)ANNOUNCE $(htmldir)SLIB_ANNOUNCE
- $(RSYNC) $(htmldir)SLIB.html $(htmldir)SLIB_ANNOUNCE nestle.ai.mit.edu:public_html/
- $(RSYNC) $(dest)README $(dest)slib$(VERSION).zip nestle.ai.mit.edu:dist/
+release: dist rpm
+ cvs tag -F slib$(VERSION)
+ cp ANNOUNCE $(htmldir)SLIB_ANNOUNCE.txt
+ cp COPYING $(htmldir)SLIB_COPYING.txt
+ $(RSYNC) $(htmldir)SLIB.html $(htmldir)SLIB_ANNOUNCE.txt \
+ $(htmldir)SLIB_COPYING.txt nestle.ai.mit.edu:public_html/
+ $(RSYNC) $(dest)README $(dest)slib$(VERSION).zip \
+ $(dest)slib-$(VERSION)-1.noarch.rpm\
+ $(dest)slib-$(VERSION)-1.src.rpm nestle.ai.mit.edu:dist/
# upload $(dest)README $(dest)slib$(VERSION).zip ftp.gnu.org:gnu/jacal/
# $(MAKE) indiana
indiana:
@@ -218,7 +204,15 @@ upzip: $(HOME)/pub/slib.zip
dist: $(dest)slib$(VERSION).zip
$(dest)slib$(VERSION).zip: temp/slib
$(makedev) DEST=$(dest) PROD=slib ver=$(VERSION) zip
- cvs tag -F slib$(VERSION)
+
+rpm: pubzip
+#$(dest)slib-$(VERSION)-1.noarch.rpm: $(dest)slib$(VERSION).zip
+ cp $(HOME)/pub/slib.zip $(rpm_prefix)SOURCES/slib$(VERSION).zip
+ rpm -ba slib.spec # --clean
+ rm $(rpm_prefix)SOURCES/slib$(VERSION).zip
+ mv $(rpm_prefix)RPMS/noarch/slib-$(VERSION)-1.noarch.rpm \
+ $(rpm_prefix)SRPMS/slib-$(VERSION)-1.src.rpm $(dest)
+
shar: slib.shar
slib.shar: temp/slib
$(makedev) PROD=slib shar
@@ -270,18 +264,29 @@ new:
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)SLIB.html $(htmldir)JACAL.html \
+ $(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
- cvs commit -m '(*SLIB-VERSION*): Bumped from $(VERSION) to $(ver).'
- cvs tag -F slib$(ver)
+ $(htmldir)SLIB.html slib.spec scheme48.init s48-0_57.init
+ cvs commit -lm '(*SLIB-VERSION*): Bumped from $(VERSION) to $(ver).'
+ cvs tag -lF slib$(ver)
-tagfiles = version.txi slib.texi $(mfiles) $(sfiles) $(bfiles) $(tfiles)
+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)
diff --git a/README b/README
index daae3a6..8d4d31d 100644
--- a/README
+++ b/README
@@ -1,15 +1,15 @@
-This directory contains the distribution of Scheme Library slib2c7.
+This directory contains the distribution of Scheme Library slib2d2.
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.
+The maintainer can be reached at agj @ alum.mit.edu.
http://swissnet.ai.mit.edu/~jaffer/SLIB.html
MANIFEST
`README' is this file. It contains a MANIFEST, INSTALLATION
- INSTRUCTIONS, and proposed coding standards.
+ 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.
@@ -18,22 +18,23 @@ The maintainer can be reached at jaffer @ ai.mit.edu.
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.
+ `scheme2c.init' is a configuration file for DEC's scheme->c.
`scheme48.init' is a configuration file for Scheme48.
+ `s48-0_57.init is a configuration file for Scheme48-0.57.
`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.
+ `guile.init' is a configuration file for guile.
`mklibcat.scm' builds the *catalog* cache.
`require.scm' has code which allows system independent access to
the library files.
@@ -56,6 +57,7 @@ The maintainer can be reached at jaffer @ ai.mit.edu.
`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.
+ `differ.scm' An O(NP) Sequence Comparison Algorithm.
`alist.scm' has functions accessing and modifying association lists.
`hash.scm' defines hash, hashq, and hashv.
@@ -68,6 +70,7 @@ The maintainer can be reached at jaffer @ ai.mit.edu.
`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.
@@ -87,8 +90,11 @@ The maintainer can be reached at jaffer @ ai.mit.edu.
`alistab.scm' has association list base tables.
`dbutil.scm' has utilities for creating and manipulating relational
databases.
- `htmlform' generates HTML2.0 forms and service CGI requests from RDB
- command tables.
+ `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.
@@ -135,6 +141,7 @@ The maintainer can be reached at jaffer @ ai.mit.edu.
`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".
@@ -147,23 +154,49 @@ The maintainer can be reached at jaffer @ ai.mit.edu.
`ratize.scm' has function rationalize from Revised^4 spec.
`trnscrpt.scm' has transcript-on and transcript-off from Revised^4 spec.
`withfile.scm' has with-input-from-file and with-output-to-file from R4RS.
- `dynwind.scm' has proposed dynamic-wind from R5RS.
- `eval.scm' has proposed eval with environments from R5RS.
+ `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 proposed DYNAMIC data type.
+ `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.
+ `structure.scm' has undocumented syntax-case macros.
`byte.scm' has arrays of small integers.
- `nclients' provides a Scheme interface to FTP and WWW Browsers.
+ `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.
+ `srfi.scm' implements Scheme Request for Implementation.
+ `srfi-N.scm' implements srfi-N.
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.
+ There are four parts to installation:
+
+ * Unpack the SLIB distribution.
+
+ * Configure the Scheme implementation(s) to locate the SLIB
+ directory.
+
+ * Arrange for Scheme implementation to load its SLIB initialization
+ file.
+
+ * Build the SLIB catalog for the Scheme implementation.
+
+Unpacking the SLIB Distribution
+-------------------------------
+
+ If the SLIB distribution is a Linux RPM, it will create the SLIB
+directory `/usr/share/slib'.
+
+ If the SLIB distribution is a ZIP file, unzip the distribution to
+create the SLIB directory. Locate this `slib' directory either in your
+home directory (if only you will use this SLIB installation); or put it
+in a location where libraries reside on your system. On unix systems
+this might be `/usr/share/slib', `/usr/local/lib/slib', or
+`/usr/lib/slib'. If you know where SLIB should go on other platforms,
+please inform agj @ alum.mit.edu.
+
+Configure Scheme Implementation to Locate SLIB
+----------------------------------------------
If the Scheme implementation supports `getenv', then the value of the
shell environment variable SCHEME_LIBRARY_PATH will be used for
@@ -172,30 +205,101 @@ 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.)
+ The `(library-vicinity)' can also be specified from the SLIB
+initialization file or by implementation-specific means.
+
+Loading SLIB Initialization File
+--------------------------------
+
+ 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.
+
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.
+ Once this is done, modify the startup file for your Scheme
+implementation to `load' this initialization file.
+
+Build New SLIB Catalog for Implementation
+-----------------------------------------
+
+ When SLIB is first used from an implementation, a file named
+`slibcat' is written to the `implementation-vicinity' for that
+implementation. Because users may lack permission to write in
+`implementation-vicinity', it is good practice to build the new catalog
+when installing SLIB.
+
+ To build (or rebuild) the catalog, start the Scheme implementation
+(with SLIB), then:
+
+ (require 'new-catalog)
+
+Implementation-specific Instructions
+------------------------------------
Multiple implementations of Scheme can all use the same SLIB
directory. Simply configure each implementation's initialization file
as outlined above.
- The SCM implementation does not require any initialization file as
-SLIB support is already built in to SCM. See the documentation with
-SCM for installation instructions.
+ - 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
+ The `init.ss' file in the _slibinit_ collection is an SLIB
+ initialization file.
+
+ To use SLIB in MzScheme, set the SCHEME_LIBRARY_PATH environment
+ variable to the installed SLIB location; then invoke MzScheme thus:
+
+ `mzscheme -L init.ss slibinit'
+
+ - Implementation: MIT Scheme
+ `scheme -load ${SCHEME_LIBRARY_PATH}mitscheme.init'
- SLIB includes methods to create heap images for the VSCM and Scheme48
-implementations. The instructions for creating a VSCM image are in
-comments in `vscm.init'. To make a Scheme48 image for an installation
-under `<prefix>', `cd' to the SLIB directory and type `make
-prefix=<prefix> slib48'. 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: Guile
+ `guile -l ${SCHEME_LIBRARY_PATH}guile.init'
PORTING INSTRUCTIONS
@@ -219,10 +323,10 @@ 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
+ Please mail new working configuration files to `agj @ alum.mit.edu' so
that they can be included in the SLIB distribution.
- CODING STANDARDS
+ CODING GUIDELINES
All library packages are written in IEEE P1178 Scheme and assume that
a configuration file and `require.scm' package have already been
diff --git a/RScheme.init b/RScheme.init
index b16b286..c03119c 100644
--- a/RScheme.init
+++ b/RScheme.init
@@ -5,22 +5,6 @@
;;; 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.
@@ -32,8 +16,8 @@
(define (scheme-implementation-type) 'RScheme)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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/")
@@ -79,57 +63,69 @@
;(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.
+
+ ;; Scheme report features
+
+; rev5-report ;conforms to
+; eval ;R5RS two-argument eval
+; values ;R5RS multiple values
+; dynamic-wind ;R5RS dynamic-wind
+; macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+ char-ready?
+; rationalize
rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
+
+ rev4-report ;conforms to
+
+ ieee-p1178 ;conforms to
+
+; rev3-report ;conforms to
+
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
+; object-hash ;has OBJECT-HASH
+
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
+; ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
full-continuation ;can return multiple times
-; object-hash ;has OBJECT-HASH
+ ;; Other common features
+
+ srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+; defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+ string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
; sort
-; queue ;queues
; pretty-print
; object->string
-; format
+; format ;Common-lisp output formatting
; 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
+
+ ;; Implementation Specific features
+
))
;;; (OUTPUT-PORT-WIDTH <port>)
@@ -231,8 +227,16 @@
(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.
diff --git a/STk.init b/STk.init
index 47c2e2d..b4f256d 100644
--- a/STk.init
+++ b/STk.init
@@ -6,7 +6,7 @@
(require "unix")
;;; (software-type) should be set to the generic operating system type.
-;;; UNIX, VMS, MACOS, AMIGA and MSDOS are supported.
+;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
(define (software-type) 'UNIX)
@@ -15,8 +15,8 @@
(define (scheme-implementation-type) '|STk|)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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)
@@ -40,8 +40,11 @@
(let ((library-path (or (getenv "SCHEME_LIBRARY_PATH") "/usr/local/lib/slib/")))
(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 (or (getenv "HOME") "/")))
(lambda () home-path)))
@@ -55,56 +58,69 @@
;(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.
+
+ ;; Scheme report features
+
+; rev5-report ;conforms to
+ eval ;R5RS two-argument eval
+; values ;R5RS multiple values
+ dynamic-wind ;R5RS dynamic-wind
+; macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+; char-ready?
+; rationalize
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
+
+ rev4-report ;conforms to
+
+ ieee-p1178 ;conforms to
+
+; rev3-report ;conforms to
+
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
+; object-hash ;has OBJECT-HASH
+
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
+ ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
full-continuation ;can return multiple times
-; object-hash ;has OBJECT-HASH
-; sort ; commented because icomplete
-; queue ;queues
+ ;; Other common features
+
+ srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+; defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+ string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
+; sort
; pretty-print
; object->string
-; format
+; format ;Common-lisp output formatting
+; 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
+
+ ;; Implementation Specific features
+
))
;;; (OUTPUT-PORT-WIDTH <port>)
@@ -178,13 +194,21 @@
(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:tab (integer->char 9))
(define slib:form-feed (integer->char 12))
;;; Define these if your implementation's syntax can support it and if
diff --git a/Template.scm b/Template.scm
index 9d30d40..6421d92 100644
--- a/Template.scm
+++ b/Template.scm
@@ -13,8 +13,8 @@
(define (scheme-implementation-type) 'Template)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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)
@@ -30,7 +30,7 @@
(define (implementation-vicinity)
(case (software-type)
- ((UNIX) "/usr/local/src/scheme/")
+ ((UNIX) "/usr/local/src/scheme/")
((VMS) "scheme$src:")
((MS-DOS) "C:\\scheme\\")))
@@ -68,57 +68,69 @@
;(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,
+
+ ;; Scheme report features
+
+ rev5-report ;conforms to
+ eval ;R5RS two-argument eval
+ values ;R5RS multiple values
+ dynamic-wind ;R5RS dynamic-wind
+ macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+ char-ready?
+ rationalize
+ rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
+
+ rev4-report ;conforms to
+
+ ieee-p1178 ;conforms to
+
+; rev3-report ;conforms to
+
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
+; object-hash ;has OBJECT-HASH
+
; 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
+ ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
full-continuation ;can return multiple times
-; object-hash ;has OBJECT-HASH
+ ;; Other common features
+
+ srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+; defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+; string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
; sort
-; queue ;queues
; pretty-print
; object->string
-; format
+; format ;Common-lisp output formatting
; 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
+
+ ;; Implementation Specific features
+
))
;;; (OUTPUT-PORT-WIDTH <port>)
@@ -150,6 +162,13 @@
;;; 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)
@@ -175,18 +194,20 @@
(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)))
+ (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)))
+ (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
@@ -201,6 +222,9 @@
(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))))
@@ -213,17 +237,17 @@
(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))))
+ (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 error)
+(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))
diff --git a/alist.scm b/alist.scm
index 65ddb22..5917c7c 100644
--- a/alist.scm
+++ b/alist.scm
@@ -1,9 +1,9 @@
;;;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/alistab.scm b/alistab.scm
index 426a4e3..e51bd26 100644
--- a/alistab.scm
+++ b/alistab.scm
@@ -1,9 +1,9 @@
;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -282,22 +282,23 @@
(let ((row (assoc* ckey (handle->alist handle))))
(and row (cdr row)))))
-(define (for-each-key handle operation match-key)
+(define (for-each-key handle operation primary-limit column-type-list match-keys)
(assoc*-for-each operation
'()
- match-key
+ match-keys
(handle->alist handle)))
-(define (map-key handle operation match-key)
+(define (map-key handle operation primary-limit column-type-list match-keys)
(assoc*-map operation
'()
- match-key
+ match-keys
(handle->alist handle)))
-(define (ordered-for-each-key handle operation match-key)
+(define (ordered-for-each-key handle operation
+ primary-limit column-type-list match-keys)
(sorted-assoc*-for-each operation
'()
- match-key
+ match-keys
(handle->alist handle)))
(define (supported-type? type)
@@ -338,9 +339,9 @@
(set-handle-alist! handle
(delete-assoc ckey (handle->alist handle)))))
((delete*)
- (lambda (handle match-key)
+ (lambda (handle primary-limit column-type-list match-keys)
(set-handle-alist! handle
- (delete-assoc* match-key
+ (delete-assoc* match-keys
(handle->alist handle)))))
((for-each-key) for-each-key)
((map-key) map-key)
diff --git a/array.scm b/array.scm
index 08b8114..47df853 100644
--- a/array.scm
+++ b/array.scm
@@ -1,279 +1,228 @@
;;;;"array.scm" Arrays for Scheme
-; Copyright (C) 1993 Alan Bawden
+; Copyright (C) 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
-; 1. Any copy made of this software must include this copyright notice
-; in full.
+;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.
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
;
-; 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
+;3. In conjunction with products arising from the use of 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 'record)
+;;@code{(require 'array)}
+;;@ftindex array
-;(declare (usual-integrations))
+(require 'record)
(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))
+ (make-record-type "array"
+ '(shape
+ scales ;list of dimension scales
+ offset ;exact integer
+ store ;data
+ )))
+
+(define array:shape (record-accessor array:rtd 'shape))
+
+(define array:scales
+ (let ((scales (record-accessor array:rtd 'scales)))
+ (lambda (obj)
+ (cond ((string? obj) '(1))
+ ((vector? obj) '(1))
+ (else (scales obj))))))
+
+(define array:store
+ (let ((store (record-accessor array:rtd 'store)))
+ (lambda (obj)
+ (cond ((string? obj) obj)
+ ((vector? obj) obj)
+ (else (store obj))))))
+
+(define array:offset
+ (let ((offset (record-accessor array:rtd 'offset)))
+ (lambda (obj)
+ (cond ((string? obj) 0)
+ ((vector? obj) 0)
+ (else (offset obj))))))
+(define array:construct
+ (record-constructor array:rtd '(shape scales offset store)))
+
+;;@args obj
+;;Returns @code{#t} if the @1 is an array, and @code{#f} if not.
+(define array?
+ (let ((array:array? (record-predicate array:rtd)))
+ (lambda (obj) (or (string? obj) (vector? obj) (array:array? obj)))))
+
+;;@noindent
+;;@emph{Note:} Arrays are not disjoint from other Scheme types. Strings
+;;and vectors also satisfy @code{array?}. A disjoint array predicate can
+;;be written:
+;;
+;;@example
+;;(define (strict-array? obj)
+;; (and (array? obj) (not (string? obj)) (not (vector? obj))))
+;;@end example
+
+;;@body
+;;Returns @code{#t} if @1 and @2 have the same rank and shape and the
+;;corresponding elements of @1 and @2 are @code{equal?}.
+;;
+;;@example
+;;(array=? (make-array 'foo 3 3) (make-array 'foo '(0 2) '(1 2)))
+;; @result{} #t
+;;@end example
+(define (array=? array1 array2)
+ (and (equal? (array:shape array1) (array:shape array2))
+ (equal? (array:store array1) (array:store array2))))
+
+(define (array:dimensions->shape dims)
+ (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dims))
+
+;;@args initial-value bound1 bound2 @dots{}
+;;Creates and returns an array with dimensions @var{bound1},
+;;@var{bound2}, @dots{} and filled with @1.
+(define (make-array initial-value . dimensions)
+ (let* ((shape (array:dimensions->shape dimensions))
+ (dims (map (lambda (bnd) (- 1 (apply - bnd))) shape))
+ (scales (reverse (cons 1 (cdr (reverse dims))))))
+ (array:construct shape
+ scales
+ (- (apply + (map * (map car shape) scales)))
+ (make-vector (apply * dims) initial-value))))
+
+;;@noindent
+;;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
+;;
+;;@example
+;;(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2))
+;;@end example
+
+;;@args 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:
+;;
+;;@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)
+;; @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 example
+(define (make-shared-array array mapper . dimensions)
+ (define odl (array:scales array))
+ (define rank (length dimensions))
+ (define shape (array:dimensions->shape dimensions))
+ (do ((idx (+ -1 rank) (+ -1 idx))
+ (uvt (append (cdr (vector->list (make-vector rank 0))) '(1))
+ (append (cdr uvt) '(0)))
+ (uvts '() (cons uvt uvts)))
+ ((negative? idx)
+ (let* ((ker0 (apply + (map * odl (apply mapper uvt))))
+ (scales (map (lambda (uvt)
+ (- (apply + (map * odl (apply mapper uvt))) ker0))
+ uvts)))
+ (array:construct
+ shape
+ scales
+ (- (apply + (array:offset array)
+ (map * odl (apply mapper (map car shape))))
+ (apply + (map * (map car shape) scales)))
+ (array:store array))))))
+
+;;@body
+;;Returns the number of dimensions of @1. If @1 is not an array, 0 is
+;;returned.
(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))))
+;;@body
+;;Returns a list of inclusive bounds.
+;;
+;;@example
+;;(array-shape (make-array 'foo 3 5))
+;; @result{} ((0 2) (0 4))
+;;@end example
+(define array-shape
+ (lambda (array)
+ (cond ((vector? array) (list (list 0 (+ -1 (vector-length array)))))
+ ((string? array) (list (list 0 (+ -1 (string-length array)))))
+ (else (array:shape array)))))
+
+;;@body
+;;@code{array-dimensions} is similar to @code{array-shape} but replaces
+;;elements with a 0 minimum with one greater than the maximum.
+;;
+;;@example
+;;(array-dimensions (make-array 'foo 3 5))
+;; @result{} (3 5)
+;;@end example
+(define (array-dimensions array)
+ (map (lambda (bnd) (if (zero? (car bnd)) (+ 1 (cadr bnd)) bnd))
+ (array-shape array)))
(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))
-
+ (do ((bnds (array:shape array) (cdr bnds))
+ (idxs indices (cdr idxs)))
+ ((or (null? bnds)
+ (null? idxs)
+ (not (integer? (car idxs)))
+ (not (<= (caar bnds) (car idxs) (cadar bnds))))
+ (and (null? bnds) (null? idxs)))))
+
+;;@args array index1 index2 @dots{}
+;;Returns @code{#t} if its arguments would be acceptable to
+;;@code{array-ref}.
(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))))))
+;;@args array index1 index2 @dots{}
+;;Returns the (@2, @3, @dots{}) element of @1.
+(define (array-ref array . indices)
+ (define store (array:store array))
+ (or (array:in-bounds? array indices)
+ (slib:error 'array-ref 'bad-indices indices))
+ ((if (string? store) string-ref vector-ref)
+ store (apply + (array:offset array) (map * (array:scales array) indices))))
+
+;;@args array obj index1 index2 @dots{}
+;;Stores @2 in the (@3, @4, @dots{}) element of @1. The value returned
+;;by @0 is unspecified.
+(define (array-set! array obj . indices)
+ (define store (array:store array))
+ (or (array:in-bounds? array indices)
+ (slib:error 'array-set! 'bad-indices indices))
+ ((if (string? store) string-set! vector-set!)
+ store (apply + (array:offset array) (map * (array:scales array) indices))
+ obj))
+
+;;; Legacy functions
+
+;; These procedures are fast versions of @code{array-ref} and
+;; @code{array-set!} for non-string arrays; they take a fixed number of
+;; arguments and perform no bounds checking.
+(define array-1d-ref array-ref)
+(define array-2d-ref array-ref)
+(define array-3d-ref array-ref)
+(define array-1d-set! array-set!)
+(define array-2d-set! array-set!)
+(define array-3d-set! array-set!)
diff --git a/array.txi b/array.txi
new file mode 100644
index 0000000..5d30b19
--- /dev/null
+++ b/array.txi
@@ -0,0 +1,111 @@
+@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
+@noindent
+@emph{Note:} Arrays are not disjoint from other Scheme types. Strings
+and vectors also satisfy @code{array?}. A disjoint array predicate can
+be written:
+
+@example
+(define (strict-array? obj)
+ (and (array? obj) (not (string? obj)) (not (vector? obj))))
+@end example
+
+
+@defun array=? array1 array2
+
+Returns @code{#t} if @var{array1} and @var{array2} have the same rank and shape and the
+corresponding elements of @var{array1} and @var{array2} are @code{equal?}.
+
+@example
+(array=? (make-array 'foo 3 3) (make-array 'foo '(0 2) '(1 2)))
+ @result{} #t
+@end example
+@end defun
+
+@defun make-array initial-value bound1 bound2 @dots{}
+
+Creates and returns an array with dimensions @var{bound1},
+@var{bound2}, @dots{} and filled with @var{initial-value}.
+@end defun
+@noindent
+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
+
+@example
+(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2))
+@end example
+
+
+@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:
+
+@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)
+ @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 example
+@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
+
+Returns a list of inclusive bounds.
+
+@example
+(array-shape (make-array 'foo 3 5))
+ @result{} ((0 2) (0 4))
+@end example
+@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.
+
+@example
+(array-dimensions (make-array 'foo 3 5))
+ @result{} (3 5)
+@end example
+@end defun
+
+@defun array-in-bounds? array index1 index2 @dots{}
+
+Returns @code{#t} if its arguments would be acceptable to
+@code{array-ref}.
+@end defun
+
+@defun array-ref array index1 index2 @dots{}
+
+Returns the (@var{index1}, @var{index2}, @dots{}) element of @var{array}.
+@end defun
+
+@defun array-set! array obj index1 index2 @dots{}
+
+Stores @var{obj} in the (@var{index1}, @var{index2}, @dots{}) element of @var{array}. The value returned
+by @code{array-set!} is unspecified.
+@end defun
diff --git a/arraymap.scm b/arraymap.scm
index ab3d7c8..15e24da 100644
--- a/arraymap.scm
+++ b/arraymap.scm
@@ -1,9 +1,9 @@
;;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/batch.scm b/batch.scm
index d77519d..45b404c 100644
--- a/batch.scm
+++ b/batch.scm
@@ -1,9 +1,9 @@
;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/bigloo.init b/bigloo.init
index 14b9c9e..41a4179 100644
--- a/bigloo.init
+++ b/bigloo.init
@@ -1,23 +1,7 @@
;; "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.
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
(define (software-type) 'UNIX)
@@ -26,16 +10,16 @@
(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) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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")
+;;; (scheme-implementation-version) should return a string describing
+;;; the version the scheme implementation loading this file.
+
(define (scheme-implementation-version) "2.0c")
;;; (implementation-vicinity) should be defined to be the pathname of
@@ -44,9 +28,9 @@
(define (implementation-vicinity)
(case (software-type)
- ((UNIX) "/usr/unsup/lib/bigloo/")
+ ((UNIX) "/usr/local/lib/bigloo/")
((VMS) "scheme$src:")
- ((MSDOS) "C:\\scheme\\")))
+ ((MS-DOS) "C:\\scheme\\")))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
@@ -59,9 +43,9 @@
;; 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/")
+ ((UNIX) "/usr/share/slib/")
((VMS) "lib$scheme:")
- ((MSDOS) "C:\\SLIB\\")
+ ((MS-DOS) "C:\\SLIB\\")
(else "")))))
(lambda () library-path)))
@@ -78,45 +62,82 @@
;;; names.
(define *features*
- '(
- source ;can load scheme source files
+ '(
+ 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
- ))
+; compiled ;can load compiled files
+ ;(slib:load-compiled "filename")
+
+ ;; Scheme report features
+
+; rev5-report ;conforms to
+ eval ;R5RS two-argument eval
+; values ;R5RS multiple values
+; dynamic-wind ;R5RS dynamic-wind
+; macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+; char-ready?
+ rationalize
+ rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
+ ;LIST->STRING, STRING-COPY,
+ ;STRING-FILL!, LIST->VECTOR,
+ ;VECTOR->LIST, and VECTOR-FILL!
+
+ rev4-report ;conforms to
+
+ ieee-p1178 ;conforms to
+
+ rev3-report ;conforms to
+
+; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
+ ;SUBSTRING-MOVE-RIGHT!,
+ ;SUBSTRING-FILL!,
+ ;STRING-NULL?, APPEND!, 1+,
+ ;-1+, <?, <=?, =?, >?, >=?
+ object-hash ;has OBJECT-HASH
+
+ multiarg/and- ;/ and - can take more than 2 args.
+ with-file ;has WITH-INPUT-FROM-FILE and
+ ;WITH-OUTPUT-FROM-FILE
+ transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
+ ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
+;; full-continuation ;not without the -call/cc switch
+
+ ;; Other common features
+
+ srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+ defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+ string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
+; sort
+ pretty-print
+ object->string
+; format ;Common-lisp output formatting
+; 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)
+; current-time ;returns time in seconds since 1/1/1970
+
+ ;; Implementation Specific features
+
+ promise
+ string-case
+ ))
(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)
@@ -149,20 +170,24 @@
(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
+;;; 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.
+;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define slib:eval eval)
(define-macro (defmacro name . forms)
@@ -186,7 +211,17 @@
(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 "" args))
;; define these as appropriate for your system.
@@ -194,7 +229,7 @@
(define slib:form-feed (integer->char 12))
;;; records
-(defmacro define-record forms
+(defmacro define-record forms
(let* ((name (car forms))
(maker-name (symbol-append 'make- name)))
`(begin
@@ -205,9 +240,12 @@
(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 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)
diff --git a/break.scm b/break.scm
index e6ba634..4d18efc 100644
--- a/break.scm
+++ b/break.scm
@@ -1,9 +1,9 @@
;;;; "break.scm" Breakpoints for debugging in Scheme.
-;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -35,6 +35,7 @@
(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
@@ -71,14 +72,14 @@
(define bkpt debug:breakpoint)
(define continue debug:continue)
-(define debug:breakf
+(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! debug:indent 0)
+ ;; (set! trace:indent 0)
(let ((name (if (null? optname) function (car optname))))
(lambda args
(cond ((and (not (null? args))
@@ -92,8 +93,8 @@
;;; the reason I use a symbol for debug:unbreak-object is so
;;; that functions can still be unbreaked if this file is read in twice.
-(define (debug:unbreakf function)
-;;; (set! debug:indent 0)
+(define (unbreakf function)
+ ;; (set! trace:indent 0)
(function 'debug:unbreak-object))
;;;;The break: functions wrap around the debug: functions to provide
@@ -117,7 +118,7 @@
(cond ((and p (eq? (cdr p) fun))
fun)
(else
- (let ((tfun (debug:breakf fun sym)))
+ (let ((tfun (breakf fun sym)))
(set! *breakd-procedures*
(break:adder *breakd-procedures* sym tfun))
tfun)))))))
@@ -128,12 +129,9 @@
(cond ((not (procedure? fun)) fun)
((not p) fun)
((eq? (cdr p) fun)
- (debug:unbreakf fun))
+ (unbreakf fun))
(else fun))))
-(define breakf debug:breakf)
-(define unbreakf debug:unbreakf)
-
;;;; Finally, the macros break and unbreak
(defmacro break xs
diff --git a/chap.scm b/chap.scm
index 6a20aeb..0d8f99f 100644
--- a/chap.scm
+++ b/chap.scm
@@ -1,9 +1,9 @@
;;;; "chap.scm" Chapter ordering -*-scheme-*-
-;;; Copyright 1992, 1993, 1994 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/charplot.scm b/charplot.scm
index 2c64615..3e0e019 100644
--- a/charplot.scm
+++ b/charplot.scm
@@ -1,9 +1,9 @@
;;;; "charplot.scm", plotting on character devices for Scheme
-;;; Copyright (C) 1992, 1993 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -19,6 +19,8 @@
(require 'sort)
(require 'printf)
+(require 'array)
+(require 'array-for-each)
(define charplot:rows 24)
(define charplot:columns (output-port-width (current-output-port)))
@@ -47,31 +49,33 @@
(define (charplot:number->string x)
(sprintf #f "%g" x))
-(define (scale-it z scale)
+(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 (find-scale isize delta)
- (if (inexact? delta) (set! isize (exact->inexact isize)))
+(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 (cond ((< (* delta 8) isize) 8)
- ((< (* delta 6) isize) 6)
- ((< (* delta 5) isize) 5)
- ((< (* delta 4) isize) 4)
- ((< (* delta 3) isize) 3)
- ((< (* delta 2) isize) 2)
- (else 1)))
- d))
+ (list (* n (fs2)) d))
(set! delta (* delta 10))))
(set! isize (* isize 10))))
(define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale)
- (define xaxis (- (scale-it ymin yscale)))
- (define yaxis (- (scale-it xmin xscale)))
+ (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)
@@ -122,7 +126,7 @@
(display charplot:yborder) (newline)
(charplot:center-print! xlabel (+ 12 fudge (- xstep/2)))
(do ((i fudge (+ i xstep)))
- ((> (+ i xstep) charplot:width))
+ ((>= i charplot:width))
(charplot:center-print! (charplot:number->string
(/ (* (- i yaxis) (cadr xscale))
(car xscale)))
@@ -131,23 +135,30 @@
(define (charplot:plot! data xlabel ylabel)
(cond ((array? data)
- (set! data (map (lambda (lst) (cons (car lst) (cadr lst)))
- (array->list 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 (find-scale charplot:width (- xmax xmin)))
+ (xscale (charplot:find-scale charplot:width (- xmax xmin)))
(ymax (apply max (map cdr data)))
(ymin (apply min (map cdr data)))
- (yscale (find-scale charplot:height (- ymax ymin)))
- (ixmin (scale-it xmin xscale))
- (iymin (scale-it ymin yscale)))
+ (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 (- (scale-it (car p) xscale) ixmin)
- (- (scale-it (cdr p) yscale) iymin)))
+ (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)
+(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)
diff --git a/chez.init b/chez.init
index 4b58b84..44acba8 100644
--- a/chez.init
+++ b/chez.init
@@ -16,8 +16,8 @@
(define (scheme-implementation-type) 'chez)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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)
@@ -64,66 +64,76 @@
;;; 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.
+ '(
+ source ;can load scheme source files
+ ;(slib:load-source "filename")
+ compiled ;can load compiled files
+ ;(slib:load-compiled "filename")
- 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.
+ ;; Scheme report features
+
+ rev5-report ;conforms to
+ eval ;R5RS two-argument eval
+ values ;R5RS multiple values
+ dynamic-wind ;R5RS dynamic-wind
+ macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+ char-ready?
+ rationalize
rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
+
+ rev4-report ;conforms to
+
+ ieee-p1178 ;conforms to
+
+ rev3-report ;conforms to
+
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
+; object-hash ;has OBJECT-HASH
+
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
+; ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
full-continuation ;can return multiple times
-; object-hash ;has OBJECT-HASH
+ ;; Other common features
+
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+; defmacro ;has Common Lisp DEFMACRO
+ record ;has user defined data structures
+ string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
sort
-; queue ;queues
pretty-print
; object->string
- format
+ format ;Common-lisp output formatting
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
+
+ ;; Implementation Specific features
+
fluid-let
random
- rev3-procedures
))
;;; (OUTPUT-PORT-WIDTH <port>) returns the number of graphic characters
@@ -179,8 +189,12 @@
;; port to be transferred all the way out to its ultimate destination.
(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.
+;;; "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.
@@ -201,9 +215,10 @@
;;; define an error procedure for the library
(define slib:error
(lambda args
- (let ((port (current-error-port)))
- (display "Error: " port)
- (for-each (lambda (x) (display x port)) 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.
@@ -379,9 +394,10 @@
(define slib:warn
(lambda args
- (let ((port (current-error-port)))
- (display "Warn: " port)
- (for-each (lambda (x) (display x port)) 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.
diff --git a/cltime.scm b/cltime.scm
index 441e7f9..d22922c 100644
--- a/cltime.scm
+++ b/cltime.scm
@@ -1,9 +1,9 @@
;;;; "cltime.scm" Common-Lisp time conversion routines.
-;;; Copyright (C) 1994, 1997 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/coerce.scm b/coerce.scm
new file mode 100644
index 0000000..83023df
--- /dev/null
+++ b/coerce.scm
@@ -0,0 +1,107 @@
+;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF.
+; Copyright (C) 1995, 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;@body
+;;Returns a symbol name for the type of @1.
+(define (type-of obj)
+ (cond
+ ;;((null? obj) 'null)
+ ((boolean? obj) 'boolean)
+ ((char? obj) 'char)
+ ((number? obj) 'number)
+ ((string? obj) 'string)
+ ((symbol? obj) 'symbol)
+ ((input-port? obj) 'port)
+ ((output-port? obj) 'port)
+ ((procedure? obj) 'procedure)
+ ((eof-object? obj) 'eof-object)
+ ((list? obj) 'list)
+ ((pair? obj) 'pair)
+ ((and (provided? 'array) (array? obj)) 'array)
+ ((and (provided? 'record) (record? obj)) 'record)
+ ((vector? obj) 'vector)
+ (else '?)))
+
+;;@body
+;;Converts and returns @1 of type @code{char}, @code{number},
+;;@code{string}, @code{symbol}, @code{list}, or @code{vector} to
+;;@2 (which must be one of these symbols).
+(define (coerce obj result-type)
+ (define (err) (slib:error 'coerce 'not obj '-> result-type))
+ (define obj-type (type-of obj))
+ (cond
+ ((eq? obj-type result-type) obj)
+ (else
+ (case obj-type
+ ((char) (case result-type
+ ((number integer) (char->integer obj))
+ ((string) (string obj))
+ ((symbol) (string->symbol (string obj)))
+ ((list) (list obj))
+ ((vector) (vector obj))
+ (else (err))))
+ ((number) (case result-type
+ ((char) (integer->char obj))
+ ((atom) obj)
+ ((integer) obj)
+ ((string) (number->string obj))
+ ((symbol) (string->symbol (number->string obj)))
+ ((list) (string->list (number->string obj)))
+ ((vector) (list->vector (string->list (number->string obj))))
+ (else (err))))
+ ((string) (case result-type
+ ((char) (if (= 1 (string-length obj)) (string-ref obj 0)
+ (err)))
+ ((atom) (or (string->number obj) (string->symbol obj)))
+ ((number integer) (or (string->number obj) (err)))
+ ((symbol) (string->symbol obj))
+ ((list) (string->list obj))
+ ((vector) (list->vector (string->list obj)))
+ (else (err))))
+ ((symbol) (case result-type
+ ((char) (coerce (symbol->string obj) 'char))
+ ((number integer) (coerce (symbol->string obj) 'number))
+ ((string) (symbol->string obj))
+ ((atom) obj)
+ ((list) (string->list (symbol->string obj)))
+ ((vector) (list->vector (string->list (symbol->string obj))))
+ (else (err))))
+ ((list) (case result-type
+ ((char) (if (and (= 1 (length obj))
+ (char? (car obj)))
+ (car obj)
+ (err)))
+ ((number integer)
+ (or (string->number (list->string obj)) (err)))
+ ((string) (list->string obj))
+ ((symbol) (string->symbol (list->string obj)))
+ ((vector) (list->vector obj))
+ (else (err))))
+ ((vector) (case result-type
+ ((char) (if (and (= 1 (vector-length obj))
+ (char? (vector-ref obj 0)))
+ (vector-ref obj 0)
+ (err)))
+ ((number integer)
+ (or (string->number (coerce obj string)) (err)))
+ ((string) (list->string (vector->list obj)))
+ ((symbol) (string->symbol (coerce obj string)))
+ ((list) (list->vector obj))
+ (else (err))))
+ (else (err))))))
diff --git a/coerce.txi b/coerce.txi
new file mode 100644
index 0000000..4b7f6b0
--- /dev/null
+++ b/coerce.txi
@@ -0,0 +1,12 @@
+
+@defun type-of obj
+
+Returns a symbol name for the type of @var{obj}.
+@end defun
+
+@defun coerce obj result-type
+
+Converts and returns @var{obj} of type @code{char}, @code{number},
+@code{string}, @code{symbol}, @code{list}, or @code{vector} to
+@var{result-type} (which must be one of these symbols).
+@end defun
diff --git a/comlist.scm b/comlist.scm
index 8ecf525..008a2b0 100644
--- a/comlist.scm
+++ b/comlist.scm
@@ -1,9 +1,10 @@
;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
-; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
+; Copyright (C) 1991, 1993, 1995, 2001 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -22,6 +23,10 @@
;;;; LIST FUNCTIONS FROM COMMON LISP
+;;; Some tail-recursive optimizations made by
+;;; Colin Walters <walters@cis.ohio-state.edu>
+;;; AGJ restored order July 2001.
+
;;;From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (comlist:make-list k . init)
(set! init (if (pair? init) (car init)))
@@ -31,23 +36,34 @@
(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)
- (cond ((null? l1) l1)
- ((null? l2) l2)
- ((memv (car l1) l2) (cons (car l1) (comlist:intersection (cdr l1) l2)))
- (else (comlist:intersection (cdr l1) l2))))
+(define (comlist:adjoin obj lst) (if (memv obj lst) lst (cons obj lst)))
+
+(define (comlist:union lst1 lst2)
+ (define ans (if (null? lst1) lst2 lst1))
+ (cond ((null? lst2) lst1)
+ (else (for-each (lambda (elt) (set! ans (comlist:adjoin elt ans)))
+ lst2)
+ ans)))
+
+(define (comlist:intersection lst1 lst2)
+ (if (null? lst2)
+ lst2
+ (let build-intersection ((lst1 lst1)
+ (result '()))
+ (cond ((null? lst1) (reverse result))
+ ((memv (car lst1) lst2)
+ (build-intersection (cdr lst1) (cons (car lst1) result)))
+ (else
+ (build-intersection (cdr lst1) result))))))
-(define (comlist:set-difference l1 l2)
- (cond ((null? l1) l1)
- ((memv (car l1) l2) (comlist:set-difference (cdr l1) l2))
- (else (cons (car l1) (comlist:set-difference (cdr l1) l2)))))
+(define (comlist:set-difference lst1 lst2)
+ (if (null? lst2)
+ lst1
+ (let build-difference ((lst1 lst1)
+ (result '()))
+ (cond ((null? lst1) (reverse result))
+ ((memv (car lst1) lst2) (build-difference (cdr lst1) result))
+ (else (build-difference (cdr lst1) (cons (car lst1) result)))))))
(define (comlist:position obj lst)
(letrec ((pos (lambda (n lst)
@@ -56,64 +72,107 @@
(else (pos (+ 1 n) (cdr lst)))))))
(pos 0 lst)))
-(define (comlist:reduce-init p init l)
- (if (null? l)
+(define (comlist:reduce-init pred? init lst)
+ (if (null? lst)
init
- (comlist:reduce-init p (p init (car l)) (cdr l))))
+ (comlist:reduce-init pred? (pred? init (car lst)) (cdr lst))))
-(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:reduce pred? lst)
+ (cond ((null? lst) lst)
+ ((null? (cdr lst)) (car lst))
+ (else (comlist:reduce-init pred? (car lst) (cdr lst)))))
-(define (comlist:some pred l . rest)
+(define (comlist:some pred lst . 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)
+ (let mapf ((lst lst))
+ (and (not (null? lst))
+ (or (pred (car lst)) (mapf (cdr lst))))))
+ (else (let mapf ((lst lst) (rest rest))
+ (and (not (null? lst))
+ (or (apply pred (car lst) (map car rest))
+ (mapf (cdr lst) (map cdr rest))))))))
+
+(define (comlist:every pred lst . 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))))))))
+ (let mapf ((lst lst))
+ (or (null? lst)
+ (and (pred (car lst)) (mapf (cdr lst))))))
+ (else (let mapf ((lst lst) (rest rest))
+ (or (null? lst)
+ (and (apply pred (car lst) (map car rest))
+ (mapf (cdr lst) (map cdr rest))))))))
(define (comlist:notany pred . ls) (not (apply comlist:some pred ls)))
(define (comlist:notevery pred . ls) (not (apply comlist:every pred ls)))
-(define (comlist:find-if t l)
- (cond ((null? l) #f)
- ((t (car l)) (car l))
- (else (comlist:find-if t (cdr l)))))
-
-(define (comlist:member-if t l)
- (cond ((null? l) #f)
- ((t (car l)) l)
- (else (comlist:member-if t (cdr l)))))
-
-(define (comlist:remove p l)
- (cond ((null? l) l)
- ((eqv? p (car l)) (comlist:remove p (cdr l)))
- (else (cons (car l) (comlist:remove p (cdr l))))))
-
-(define (comlist:remove-if p l)
- (cond ((null? l) l)
- ((p (car l)) (comlist:remove-if p (cdr l)))
- (else (cons (car l) (comlist:remove-if p (cdr l))))))
+(define (comlist: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 pred? lst)
+ (cond ((null? lst) #f)
+ ((pred? (car lst)) (car lst))
+ (else (comlist:find-if pred? (cdr lst)))))
-(define (comlist:remove-if-not p l)
- (cond ((null? l) l)
- ((p (car l)) (cons (car l) (comlist:remove-if-not p (cdr l))))
- (else (comlist:remove-if-not p (cdr l)))))
+(define (comlist:member-if pred? lst)
+ (cond ((null? lst) #f)
+ ((pred? (car lst)) lst)
+ (else (comlist:member-if pred? (cdr lst)))))
+
+(define (comlist:remove pred? lst)
+ (define head (list '*head*))
+ (let remove ((lst lst)
+ (tail head))
+ (cond ((null? lst))
+ ((eqv? pred? (car lst)) (remove (cdr lst) tail))
+ (else
+ (set-cdr! tail (list (car lst)))
+ (remove (cdr lst) (cdr tail)))))
+ (cdr head))
+
+(define (comlist:remove-if pred? lst)
+ (let remove-if ((lst lst)
+ (result '()))
+ (cond ((null? lst) (reverse result))
+ ((pred? (car lst)) (remove-if (cdr lst) result))
+ (else (remove-if (cdr lst) (cons (car lst) result))))))
+
+(define (comlist:remove-if-not pred? lst)
+ (let remove-if-not ((lst lst)
+ (result '()))
+ (cond ((null? lst) (reverse result))
+ ((pred? (car lst)) (remove-if-not (cdr lst) (cons (car lst) result)))
+ (else (remove-if-not (cdr lst) result)))))
(define comlist:nconc
(if (provided? 'rev2-procedures) append!
@@ -141,26 +200,36 @@
(comlist:nthcdr (- (length lst) n) lst))
(define (comlist:butlast lst n)
- (letrec ((l (- (length lst) n))
- (bl (lambda (lst n)
- (cond ((null? lst) lst)
- ((positive? n)
- (cons (car lst) (bl (cdr lst) (+ -1 n))))
- (else '())))))
+ (letrec
+ ((len (- (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))))
+ len))))
(define (comlist:nthcdr n lst)
(if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst))))
(define (comlist:butnthcdr n lst)
- (letrec ((bn (lambda (lst n)
- (cond ((null? lst) lst)
- ((positive? n)
- (cons (car lst) (bn (cdr lst) (+ -1 n))))
- (else '())))))
- (bn lst (if (negative? n)
+ (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))))
@@ -186,129 +255,46 @@
(define (comlist:remove-duplicates lst)
(letrec ((rem-dup
(lambda (lst nlst)
- (cond ((null? lst) nlst)
+ (cond ((null? lst) (reverse 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 (type-of obj)
- (cond
- ((null? obj) 'null)
- ((boolean? obj) 'boolean)
- ((char? obj) 'char)
- ((number? obj) 'number)
- ((string? obj) 'string)
- ((symbol? obj) 'symbol)
- ((input-port? obj) 'port)
- ((output-port? obj) 'port)
- ((procedure? obj) 'procedure)
- ((eof-object? obj) 'eof-object)
- ((list? obj) 'list)
- ((pair? obj) 'pair)
- ((and (provided? 'array) (array? obj)) 'array)
- ((and (provided? 'record) (record? obj)) 'record)
- ((vector? obj) 'vector)
- (else '?)))
-
-(define (coerce obj result-type)
- (define (err) (slib:error 'coerce "couldn't" obj '-> result-type))
- (define obj-type (type-of obj))
- (cond
- ((eq? obj-type result-type) obj)
- (else
- (case obj-type
- ((char) (case result-type
- ((number 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))))))
-
-(define (comlist:delete obj list)
- (let delete ((list list))
- (cond ((null? list) '())
- ((equal? obj (car list)) (delete (cdr list)))
+(define (comlist:list* obj1 . obj2)
+ (define (list*1 obj)
+ (if (null? (cdr obj))
+ (car obj)
+ (cons (car obj) (list*1 (cdr obj)))))
+ (if (null? obj2)
+ obj1
+ (cons obj1 (list*1 obj2))))
+
+(define (comlist:atom? obj)
+ (not (pair? obj)))
+
+(define (comlist:delete obj lst)
+ (let delete ((lst lst))
+ (cond ((null? lst) '())
+ ((equal? obj (car lst)) (delete (cdr lst)))
(else
- (set-cdr! list (delete (cdr list)))
- list))))
+ (set-cdr! lst (delete (cdr lst)))
+ lst))))
-(define (comlist:delete-if pred list)
- (let delete-if ((list list))
- (cond ((null? list) '())
- ((pred (car list)) (delete-if (cdr list)))
+(define (comlist:delete-if pred lst)
+ (let delete-if ((lst lst))
+ (cond ((null? lst) '())
+ ((pred (car lst)) (delete-if (cdr lst)))
(else
- (set-cdr! list (delete-if (cdr list)))
- list))))
+ (set-cdr! lst (delete-if (cdr lst)))
+ lst))))
-(define (comlist:delete-if-not pred list)
- (let delete-if ((list list))
- (cond ((null? list) '())
- ((not (pred (car list))) (delete-if (cdr list)))
+(define (comlist:delete-if-not pred lst)
+ (let delete-if ((lst lst))
+ (cond ((null? lst) '())
+ ((not (pred (car lst))) (delete-if (cdr lst)))
(else
- (set-cdr! list (delete-if (cdr list)))
- list))))
+ (set-cdr! lst (delete-if (cdr lst)))
+ lst))))
;;; exports
@@ -348,3 +334,4 @@
(define atom comlist:atom?)
(define atom? comlist:atom?)
(define list* comlist:list*)
+(define list-of?? comlist:list-of??)
diff --git a/comparse.scm b/comparse.scm
index 9066e36..5a007b6 100644
--- a/comparse.scm
+++ b/comparse.scm
@@ -1,9 +1,9 @@
;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/cring.scm b/cring.scm
index 320b1d2..dfbb027 100644
--- a/cring.scm
+++ b/cring.scm
@@ -1,9 +1,9 @@
;;;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/db2html.scm b/db2html.scm
new file mode 100644
index 0000000..3462966
--- /dev/null
+++ b/db2html.scm
@@ -0,0 +1,463 @@
+;"db2html.scm" Convert relational database to hyperlinked pages.
+; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'uri)
+(require 'html-form)
+(require 'net-clients)
+(require 'string-search)
+
+;;@code{(require 'db->html)}
+
+;;@body
+(define (html:table options . rows)
+ (apply string-append
+ (sprintf #f "<TABLE %s>\\n" (or options ""))
+ (append rows (list (sprintf #f "</TABLE>\\n")))))
+
+;;@args caption align
+;;@args caption
+;;@2 can be @samp{top} or @samp{bottom}.
+(define (html:caption caption . align)
+ (if (null? align)
+ (sprintf #f " <CAPTION>%s</CAPTION>\\n"
+ (html:plain caption))
+ (sprintf #f " <CAPTION ALIGN=%s>%s</CAPTION>\\n"
+ (car align)
+ (html:plain caption))))
+
+;;@body Outputs a heading row for the currently-started table.
+(define (html:heading columns)
+ (sprintf #f " <TR VALIGN=\"TOP\">\\n%s </TR>\\n"
+ (apply string-append
+ (map (lambda (datum)
+ (sprintf #f " <TH>%s</TH>\\n" (or datum "")))
+ columns))))
+
+;;@body Outputs a heading row with column-names @1 linked to URIs @2.
+(define (html:href-heading columns uris)
+ (html:heading
+ (map (lambda (column uri)
+ (if uri
+ (html:link uri column)
+ column))
+ columns uris)))
+
+(define (row->anchor pkl row)
+ (sprintf #f "<A NAME=\"%s\"></A>" (uri:make-path (butnthcdr pkl row))))
+
+;;@args k foreigns
+;;
+;;The positive integer @1 is the primary-key-limit (number of
+;;primary-keys) of the table. @2 is a list of the filenames of
+;;foreign-key field pages and #f for non foreign-key fields.
+;;
+;;@0 returns a procedure taking a row for its single argument. This
+;;returned procedure returns the html string for that table row.
+(define (html:linked-row-converter pkl foreigns)
+ (define idxs (do ((idx (length foreigns) (+ -1 idx))
+ (nats '() (cons idx nats)))
+ ((not (positive? idx)) nats)))
+ (require 'pretty-print)
+ (lambda (row)
+ (define (present datum)
+ (if (or (string? datum) (symbol? datum))
+ (html:plain datum)
+ (let* ((str (pretty-print->string datum))
+ (len (+ -1 (string-length str))))
+ (cond ((eqv? (string-index str #\newline) len)
+ (string-append "<TT>" (substring str 0 len) "</TT>"))
+ (else (html:pre str))))))
+ (sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n"
+ (apply string-append
+ (map (lambda (idx datum foreign)
+ (sprintf
+ #f " <TD>%s%s</TD>\\n"
+ (if (eqv? 1 idx) (row->anchor pkl row) "")
+ (cond ((or (not datum) (null? datum)) "")
+ ((not foreign) (present datum))
+ ((equal? "catalog-data.html" foreign)
+ (html:link (make-uri
+ (table-name->filename datum)
+ #f #f)
+ (present datum)))
+ (else (html:link (make-uri foreign #f datum)
+ (present datum))))))
+ idxs row foreigns)))))
+
+;;@body
+;;Returns the symbol @1 converted to a filename.
+(define (table-name->filename table-name)
+ (and table-name (string-append
+ (string-subst (symbol->string table-name) "*" "" ":" "_")
+ ".html")))
+
+(define (table-name->column-table-name db table-name)
+ ((((db 'open-table) '*catalog-data* #f) 'get 'coltab-name)
+ table-name))
+
+;;@args caption db table-name match-key1 @dots{}
+;;Returns HTML string for @2 table @3. Every foreign-key value is
+;;linked to the page (of the table) defining that key.
+;;
+;;The optional @4 @dots{} arguments restrict actions to a subset of
+;;the table. @xref{Table Operations, match-key}.
+(define (table->linked-html caption db table-name . args)
+ (let* ((table ((db 'open-table) table-name #f))
+ (foreigns (table 'column-foreigns))
+ (tags (map table-name->filename foreigns))
+ (names (table 'column-names))
+ (primlim (table 'primary-limit)))
+ (apply html:table "CELLSPACING=0 BORDER=1"
+ (html:caption caption 'BOTTOM)
+ (html:href-heading
+ names
+ (append (make-list primlim
+ (table-name->filename
+ (table-name->column-table-name db table-name)))
+ (make-list (- (length names) primlim) #f)))
+ (html:heading (table 'column-domains))
+ (html:href-heading foreigns tags)
+ (html:heading (table 'column-types))
+ (map (html:linked-row-converter primlim tags)
+ (apply (table 'row:retrieve*) args)))))
+
+;;@body
+;;Returns a complete HTML page. The string @3 names the page which
+;;refers to this one.
+;;
+;;The optional @4 @dots{} arguments restrict actions to a subset of
+;;the table. @xref{Table Operations, match-key}.
+(define (table->linked-page db table-name index-filename . args)
+ (string-append
+ (if index-filename
+ (html:head table-name
+ (html:link (make-uri index-filename #f table-name)
+ (html:plain table-name)))
+ (html:head table-name))
+ (html:body (apply table->linked-html table-name db table-name args))))
+
+(define (html:catalog-row-converter row foreigns)
+ (sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n"
+ (apply string-append
+ (map (lambda (datum foreign)
+ (sprintf #f " <TD>%s%s</TD>\\n"
+ (html:anchor (sprintf #f "%s" datum))
+ (html:link (make-uri foreign #f #f) datum)))
+ row foreigns))))
+
+;;@body
+;;Returns HTML string for the catalog table of @1.
+(define (catalog->html db caption . args)
+ (apply html:table "BORDER=1"
+ (html:caption caption 'BOTTOM)
+ (html:heading '(table columns))
+ (map (lambda (row)
+ (cond ((and (eq? '*columns* (caddr row))
+ (not (eq? '*columns* (car row))))
+ "")
+ (else (html:catalog-row-converter
+ (list (car row) (caddr row))
+ (list (table-name->filename (car row))
+ (table-name->filename (caddr row)))))))
+ (apply (((db 'open-table) '*catalog-data* #f) 'row:retrieve*)
+ args))))
+
+;;Returns complete HTML page (string) for the catalog table of @1.
+(define (catalog->page db caption . args)
+ (string-append (html:head caption)
+ (html:body (apply catalog->html db caption args))))
+
+;;@subsection HTML editing tables
+
+;;@noindent A client can modify one row of an editable table at a time.
+;;For any change submitted, these routines check if that row has been
+;;modified during the time the user has been editing the form. If so,
+;;an error page results.
+;;
+;;@noindent The behavior of edited rows is:
+;;
+;;@itemize @bullet
+;;@item
+;;If no fields are changed, then no change is made to the table.
+;;@item
+;;If the primary keys equal null-keys (parameter defaults), and no other
+;;user has modified that row, then that row is deleted.
+;;@item
+;;If only primary keys are changed, there are non-key fields, and no
+;;row with the new keys is in the table, then the old row is
+;;deleted and one with the new keys is inserted.
+;;@item
+;;If only non-key fields are changed, and that row has not been
+;;modified by another user, then the row is changed to reflect the
+;;fields.
+;;@item
+;;If both keys and non-key fields are changed, and no row with the
+;;new keys is in the table, then a row is created with the new
+;;keys and fields.
+;;@item
+;;If fields are changed, all fields are primary keys, and no row with
+;;the new keys is in the table, then a row is created with the new
+;;keys.
+;;@end itemize
+;;
+;;@noindent After any change to the table, a @code{sync-database} of the
+;;database is performed.
+
+;;@args table-name null-keys update delete retrieve
+;;@args table-name null-keys update delete
+;;@args table-name null-keys update
+;;@args table-name null-keys
+;;
+;;Returns procedure (of @var{db}) which returns procedure to modify row
+;;of @1. @2 is the list of @dfn{null} keys which indicate that the row
+;;is to be deleted. Optional arguments @3, @4, and @5 default to the
+;;@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @1 in
+;;@var{db}.
+(define (command:modify-table table-name null-keys . args)
+ (define argc (length args))
+ (lambda (rdb)
+ (define table ((rdb 'open-table) table-name #t))
+ (let ((table:update (or (and (> argc 0) (car args)) (table 'row:update)))
+ (table:delete (or (and (> argc 1) (cadr args)) (table 'row:delete)))
+ (table:retrieve (or (and (> argc 2) (caddr args)) (table 'row:retrieve)))
+ (pkl (length null-keys)))
+ (define ptypes (butnthcdr pkl (table 'column-types)))
+ (if (> argc 4) (slib:error 'command:modify-table 'too-many-args
+ table-name null-keys args))
+ (lambda (*keys* *row-hash* . new-row)
+ (let* ((new-pkeys (butnthcdr pkl new-row))
+ (pkeys (uri:path->keys (uri:split-fields *keys* #\/) ptypes))
+ (row (apply table:retrieve pkeys))
+ (same-nonkeys? (equal? (nthcdr pkl new-row) (nthcdr pkl row))))
+ (cond ((equal? pkeys new-pkeys) ;did not change keys
+ (cond ((not row) '("Row deleted by other user"))
+ ((equal? (crc:hash-obj row) *row-hash*)
+ (table:update new-row)
+ ((rdb 'sync-database)) #t)
+ (else '("Row changed by other user"))))
+ ((equal? null-keys new-pkeys) ;blanked keys
+ (cond ((not row) #t)
+ ((equal? (crc:hash-obj row) *row-hash*)
+ ;;(slib:warn (sprintf #f "Removing key: %#a => %#a" new-pkeys ))
+ (apply table:delete pkeys)
+ ((rdb 'sync-database)) #t)
+ (else '("Row changed by other user"))))
+ (else ;changed keys
+ (set! row (apply table:retrieve new-pkeys))
+ (cond (row (list "Row already exists"
+ (sprintf #f "%#a" row)))
+ (else (table:update new-row)
+ (if (and same-nonkeys?
+ (not (null? (nthcdr pkl new-row))))
+ (apply table:delete pkeys))
+ ((rdb 'sync-database)) #t)))))))))
+
+;;@body Given @2 in @1, creates parameter and @code{*command*} tables
+;;for editing one row of @2 at a time. @0 returns a procedure taking a
+;;row argument which returns the HTML string for editing that row.
+;;
+;;Optional @3 are expressions (lists) added to the call to
+;;@code{command:modify-table}.
+;;
+;;The domain name of a column determines the expected arity of the data
+;;stored in that column. Domain names ending in:
+;;
+;;@table @samp
+;;@item *
+;;have arity @samp{nary};
+;;@item +
+;;have arity @samp{nary1}.
+;;@end table
+(define (command:make-editable-table rdb table-name . args)
+ (define table ((rdb 'open-table) table-name #t))
+ (let ((pkl (table 'primary-limit))
+ (columns (table 'column-names))
+ (domains (table 'column-domains))
+ (types (table 'column-types))
+ (idxs (do ((idx (length (table 'column-names)) (+ -1 idx))
+ (nats '() (cons (+ 2 idx) nats)))
+ ((not (positive? idx)) nats)))
+ (ftn (((rdb 'open-table) '*domains-data* #f) 'get 'foreign-table)))
+ (define field-specs
+ (map (lambda (idx column domain type)
+ (let* ((dstr (symbol->string domain))
+ (len (+ -1 (string-length dstr))))
+ (define arity
+ (case (string-ref dstr len)
+ ((#\*) 'nary)
+ ((#\+) 'nary1)
+ (else 'single)))
+ (case (string-ref dstr len)
+ ((#\* #\+)
+ (set! type (string->symbol (substring dstr 0 len)))
+ (set! domain type)))
+ `(,idx ,column ,arity ,domain
+ ,(make-defaulter arity type) #f "")))
+ idxs columns domains types))
+ (define foreign-choice-lists
+ (map (lambda (domain-name)
+ (define tab-name (ftn domain-name))
+ (if tab-name (get-foreign-choices (rdb-open tab-name #f)) '()))
+ domains))
+ (define-tables rdb
+ `(,(symbol-append table-name '- 'params)
+ *parameter-columns* *parameter-columns*
+ ((1 *keys* single string #f #f "")
+ (2 *row-hash* single string #f #f "")
+ ,@field-specs))
+ `(,(symbol-append table-name '- 'pname)
+ ((name string))
+ ((parameter-index uint)) ;should be address-params
+ (("*keys*" 1)
+ ("*row-hash*" 2)
+ ,@(map (lambda (idx column) (list (symbol->string column) idx))
+ idxs columns)))
+ `(*commands*
+ desc:*commands* desc:*commands*
+ ((,(symbol-append 'edit '- table-name)
+ ,(symbol-append table-name '- 'params)
+ ,(symbol-append table-name '- 'pname)
+ (command:modify-table ',table-name
+ ',(map (lambda (fs)
+ (caadr (caddar (cddddr fs))))
+ (butnthcdr pkl field-specs))
+ ,@args)
+ ,(string-append "Modify " (symbol->string table-name))))))
+ (let ((arities (map caddr field-specs)))
+ (lambda (row)
+ (define elements
+ (map form:element
+ columns
+ arities
+ (map (lambda (fld arity) (case arity
+ ((nary nary1) fld)
+ (else (list fld))))
+ row arities)
+ foreign-choice-lists))
+ (sprintf #f " <TR>\\n <TD>%s</TD>%s\\n </TR>\\n"
+ (string-append
+ (html:hidden '*row-hash* (crc:hash-obj row))
+ (html:hidden '*keys* (uri:make-path (butnthcdr pkl row)))
+ ;; (html:hidden '*suggest* '<>)
+ (car elements)
+ (form:submit '<> (symbol-append 'edit '- table-name))
+ ;; (form:image "Modify Row" "/icons/bang.png")
+ )
+ (apply string-append
+ (map (lambda (elt) (sprintf #f " <TD>%s</TD>\\n" elt))
+ (cdr elements))))))))
+
+;;@args k names edit-point edit-converter
+;;
+;;The positive integer @1 is the primary-key-limit (number of
+;;primary-keys) of the table. @2 is a list of the field-names. @3 is
+;;the list of primary-keys denoting the row to edit (or #f). @4 is the
+;;procedure called with @1, @2, and the row to edit.
+;;
+;;@0 returns a procedure taking a row for its single argument. This
+;;returned procedure returns the html string for that table row.
+;;
+;;Each HTML table constructed using @0 has first @1 fields (typically
+;;the primary key fields) of each row linked to a text encoding of these
+;;fields (the result of calling @code{row->anchor}). The page so
+;;referenced typically allows the user to edit fields of that row.
+(define (html:editable-row-converter pkl names edit-point edit-converter)
+ (require 'pretty-print)
+ (let ((idxs (do ((idx (length names) (+ -1 idx))
+ (nats '() (cons idx nats)))
+ ((not (positive? idx)) nats)))
+ (datum->html
+ (lambda (datum)
+ (if (or (string? datum) (symbol? datum))
+ (html:plain datum)
+ (let* ((str (pretty-print->string datum))
+ (len (+ -1 (string-length str))))
+ (cond ((eqv? (string-index str #\newline) len)
+ (string-append "<B>" (substring str 0 len) "</B>"))
+ (else (html:pre str))))))))
+ (lambda (row)
+ (string-append
+ (sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n"
+ (apply string-append
+ (map (lambda (idx datum foreign)
+ (sprintf
+ #f " <TD>%s%s</TD>\\n"
+ (if (eqv? 1 idx) (row->anchor pkl row) "")
+ (cond ((or (not datum) (null? datum)) "")
+ ((<= idx pkl)
+ (let ((keystr (uri:make-path
+ (butnthcdr pkl row))))
+ (sprintf #f "<A HREF=\"%s#%s\">%s</A>"
+ keystr keystr
+ (datum->html datum))))
+ (else (datum->html datum)))))
+ idxs row names)))
+ (if (and edit-point edit-converter
+ (equal? (butnthcdr pkl edit-point) (butnthcdr pkl row)))
+ (edit-converter row)
+ "")))))
+
+;;@subsection HTML databases
+
+;;@body @1 must be a relational database. @2 must be #f or a
+;;non-empty string naming an existing sub-directory of the current
+;;directory.
+;;
+;;@0 creates an html page for each table in the database @1 in the
+;;sub-directory named @2, or the current directory if @2 is #f. The
+;;top level page with the catalog of tables (captioned @4) is written
+;;to a file named @3.
+(define (db->html-files db dir index-filename caption)
+ (call-with-output-file (in-vicinity (if dir (sub-vicinity "" dir) "")
+ index-filename)
+ (lambda (port)
+ (display (catalog->page db caption) port)))
+ ((((db 'open-table) '*catalog-data* #f) 'for-each-row)
+ (lambda (row)
+ (call-with-output-file
+ (in-vicinity (sub-vicinity "" dir) (table-name->filename (car row)))
+ (lambda (port)
+ (display (table->linked-page db (car row) index-filename) port))))))
+
+;;@args db dir index-filename
+;;@args db dir
+;;@1 must be a relational database. @2 must be a non-empty
+;;string naming an existing sub-directory of the current directory or
+;;one to be created. The optional string @3 names the filename of the
+;;top page, which defaults to @file{index.html}.
+;;
+;;@0 creates sub-directory @2 if neccessary, and calls
+;;@code{(db->html-files @1 @2 @3 @2)}. The @samp{file:} URI of @3 is
+;;returned.
+(define (db->html-directory db dir . index-filename)
+ (set! index-filename (if (null? index-filename)
+ "index.html"
+ (car index-filename)))
+ (if (symbol? dir) (set! dir (symbol->string dir)))
+ (if (not (file-exists? dir)) (make-directory dir))
+ (db->html-files db dir index-filename dir)
+ (path->uri (in-vicinity (sub-vicinity "" dir) index-filename)))
+
+;;@args db dir index-filename
+;;@args db dir
+;;@0 is just like @code{db->html-directory}, but calls
+;;@code{browse-url-netscape} with the uri for the top page after the
+;;pages are created.
+(define (db->netscape . args)
+ (browse-url-netscape (apply db->html-directory args)))
diff --git a/db2html.txi b/db2html.txi
new file mode 100644
index 0000000..0acdd46
--- /dev/null
+++ b/db2html.txi
@@ -0,0 +1,185 @@
+@code{(require 'db->html)}
+
+
+@defun html:table options row @dots{}
+
+@end defun
+
+@defun html:caption caption align
+
+
+@defunx html:caption caption
+@var{align} can be @samp{top} or @samp{bottom}.
+@end defun
+
+@defun html:heading columns
+Outputs a heading row for the currently-started table.
+@end defun
+
+@defun html:href-heading columns uris
+Outputs a heading row with column-names @var{columns} linked to URIs @var{uris}.
+@end defun
+
+@defun html:linked-row-converter k foreigns
+
+
+The positive integer @var{k} is the primary-key-limit (number of
+primary-keys) of the table. @var{foreigns} is a list of the filenames of
+foreign-key field pages and #f for non foreign-key fields.
+
+@code{html:linked-row-converter} returns a procedure taking a row for its single argument. This
+returned procedure returns the html string for that table row.
+@end defun
+
+@defun table-name->filename table-name
+
+Returns the symbol @var{table-name} converted to a filename.
+@end defun
+
+@defun table->linked-html caption db table-name match-key1 @dots{}
+
+Returns HTML string for @var{db} table @var{table-name}. Every foreign-key value is
+linked to the page (of the table) defining that key.
+
+The optional @var{match-key1} @dots{} arguments restrict actions to a subset of
+the table. @xref{Table Operations, match-key}.
+@end defun
+
+@defun table->linked-page db table-name index-filename arg @dots{}
+
+Returns a complete HTML page. The string @var{index-filename} names the page which
+refers to this one.
+
+The optional @var{args} @dots{} arguments restrict actions to a subset of
+the table. @xref{Table Operations, match-key}.
+@end defun
+
+@defun catalog->html db caption arg @dots{}
+
+Returns HTML string for the catalog table of @var{db}.
+@end defun
+@subsection HTML editing tables
+
+@noindent A client can modify one row of an editable table at a time.
+For any change submitted, these routines check if that row has been
+modified during the time the user has been editing the form. If so,
+an error page results.
+
+@noindent The behavior of edited rows is:
+
+@itemize @bullet
+@item
+If no fields are changed, then no change is made to the table.
+@item
+If the primary keys equal null-keys (parameter defaults), and no other
+user has modified that row, then that row is deleted.
+@item
+If only primary keys are changed, there are non-key fields, and no
+row with the new keys is in the table, then the old row is
+deleted and one with the new keys is inserted.
+@item
+If only non-key fields are changed, and that row has not been
+modified by another user, then the row is changed to reflect the
+fields.
+@item
+If both keys and non-key fields are changed, and no row with the
+new keys is in the table, then a row is created with the new
+keys and fields.
+@item
+If fields are changed, all fields are primary keys, and no row with
+the new keys is in the table, then a row is created with the new
+keys.
+@end itemize
+
+@noindent After any change to the table, a @code{sync-database} of the
+database is performed.
+
+
+@defun command:modify-table table-name null-keys update delete retrieve
+
+
+@defunx command:modify-table table-name null-keys update delete
+
+@defunx command:modify-table table-name null-keys update
+
+@defunx command:modify-table table-name null-keys
+
+Returns procedure (of @var{db}) which returns procedure to modify row
+of @var{table-name}. @var{null-keys} is the list of @dfn{null} keys which indicate that the row
+@cindex null
+is to be deleted. Optional arguments @var{update}, @var{delete}, and @var{retrieve} default to the
+@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @var{table-name} in
+@var{db}.
+@end defun
+
+@defun command:make-editable-table rdb table-name arg @dots{}
+Given @var{table-name} in @var{rdb}, creates parameter and @code{*command*} tables
+for editing one row of @var{table-name} at a time. @code{command:make-editable-table} returns a procedure taking a
+row argument which returns the HTML string for editing that row.
+
+Optional @var{args} are expressions (lists) added to the call to
+@code{command:modify-table}.
+
+The domain name of a column determines the expected arity of the data
+stored in that column. Domain names ending in:
+
+@table @samp
+@item *
+have arity @samp{nary};
+@item +
+have arity @samp{nary1}.
+@end table
+@end defun
+
+@defun html:editable-row-converter k names edit-point edit-converter
+
+
+The positive integer @var{k} is the primary-key-limit (number of
+primary-keys) of the table. @var{names} is a list of the field-names. @var{edit-point} is
+the list of primary-keys denoting the row to edit (or #f). @var{edit-converter} is the
+procedure called with @var{k}, @var{names}, and the row to edit.
+
+@code{html:editable-row-converter} returns a procedure taking a row for its single argument. This
+returned procedure returns the html string for that table row.
+
+Each HTML table constructed using @code{html:editable-row-converter} has first @var{k} fields (typically
+the primary key fields) of each row linked to a text encoding of these
+fields (the result of calling @code{row->anchor}). The page so
+referenced typically allows the user to edit fields of that row.
+@end defun
+@subsection HTML databases
+
+
+@defun db->html-files db dir index-filename caption
+@var{db} must be a relational database. @var{dir} must be #f or a
+non-empty string naming an existing sub-directory of the current
+directory.
+
+@code{db->html-files} creates an html page for each table in the database @var{db} in the
+sub-directory named @var{dir}, or the current directory if @var{dir} is #f. The
+top level page with the catalog of tables (captioned @var{caption}) is written
+to a file named @var{index-filename}.
+@end defun
+
+@defun db->html-directory db dir index-filename
+
+
+@defunx db->html-directory db dir
+@var{db} must be a relational database. @var{dir} must be a non-empty
+string naming an existing sub-directory of the current directory or
+one to be created. The optional string @var{index-filename} names the filename of the
+top page, which defaults to @file{index.html}.
+
+@code{db->html-directory} creates sub-directory @var{dir} if neccessary, and calls
+@code{(db->html-files @var{db} @var{dir} @var{index-filename} @var{dir})}. The @samp{file:} URI of @var{index-filename} is
+returned.
+@end defun
+
+@defun db->netscape db dir index-filename
+
+
+@defunx db->netscape db dir
+@code{db->netscape} is just like @code{db->html-directory}, but calls
+@code{browse-url-netscape} with the uri for the top page after the
+pages are created.
+@end defun
diff --git a/dbrowse.scm b/dbrowse.scm
index 082cef3..e186492 100644
--- a/dbrowse.scm
+++ b/dbrowse.scm
@@ -1,9 +1,9 @@
;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/dbutil.scm b/dbutil.scm
index 1ed84da..248ec1d 100644
--- a/dbutil.scm
+++ b/dbutil.scm
@@ -1,9 +1,9 @@
;;; "dbutil.scm" relational-database-utilities
-; Copyright 1994, 1995, 1997 Aubrey Jaffer
+; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -50,6 +50,18 @@
(((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)
@@ -147,17 +159,7 @@
((domain-checker
no-parameters
no-parameter-names
- (lambda (rdb)
- (let* ((ro:domains ((rdb 'open-table) '*domains-data* #f))
- (ro:get-dir (ro:domains 'get 'domain-integrity-rule))
- (ro:for-tab (ro:domains 'get 'foreign-table)))
- (lambda (domain)
- (let ((fkname (ro:for-tab domain))
- (dir (slib:eval (ro:get-dir domain))))
- (if fkname (let* ((fktab ((rdb 'open-table) fkname #f))
- (p? (fktab 'get 1)))
- (if dir (lambda (e) (and (dir e) (p? e))) p?))
- dir)))))
+ dbutil:check-domain
"return procedure to check given domain name")
(add-domain
@@ -179,12 +181,40 @@
((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))
+ ((number) '(0))
+ (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))
@@ -264,7 +294,21 @@
((tab 'close-table))))))
(for-each (lambda (spec) (apply define-table spec)) spec-list))
+(define (dbutil:list-table-definition rdb table-name)
+ (cond (((rdb 'table-exists?) table-name)
+ (let* ((table ((rdb 'open-table) table-name #f))
+ (prilimit (table 'primary-limit))
+ (coldefs (map list
+ (table 'column-names)
+ (table 'column-domains))))
+ (list table-name
+ (butnthcdr prilimit coldefs)
+ (nthcdr prilimit coldefs)
+ ((table 'row:retrieve*)))))
+ (else #f)))
+
(define create-database dbutil:create-database)
(define open-database! dbutil:open-database!)
(define open-database dbutil:open-database)
(define define-tables dbutil:define-tables)
+(define list-table-definition dbutil:list-table-definition)
diff --git a/debian/changelog b/debian/changelog
index 1c67c6c..411c3c4 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,47 @@
+slib (2d2-1) unstable; urgency=low
+
+ * New upstream version
+ * Revert back to free. Is now so.
+
+ -- James LewisMoss <dres@debian.org> Fri, 27 Jul 2001 23:45:29 -0400
+
+slib (2d1-1) unstable; urgency=low
+
+ * New upstream version.
+ * Move to non-free. FSF pointed out license doesn't allow modified
+ versions to be distributed.
+ * Get a complete list of copyrights that apply to the source into
+ copyright file.
+ * Remove setup for guile 1.3.
+ * Remove postrm. Just calling install-info (lintian) Move install-info
+ call to prerm since doc-base doesn't do install-info.
+
+ -- James LewisMoss <dres@debian.org> Mon, 21 May 2001 23:34:52 -0400
+
+slib (2c9-3) unstable; urgency=low
+
+ * Change info location to section "The Algorithmic Language Scheme" to
+ match up with where guile puts it's files.
+ * Postinst is running slibconfig now. (Closes: #75891)
+
+ -- James LewisMoss <dres@debian.org> Mon, 11 Dec 2000 03:39:43 -0500
+
+slib (2c9-2) unstable; urgency=low
+
+ * Stop installing slibconfig (for guile).
+ * In postinst if /usr/sbin/slibconnfig exists call it (Close: #75843
+ #75891).
+
+ -- James LewisMoss <dres@debian.org> Sun, 5 Nov 2000 00:10:51 -0500
+
+slib (2c9-1) unstable; urgency=low
+
+ * New upstream (Closes: #74760)
+ * replace string-index with strsrch:string-index in http-cgi.scm.
+ * Add doc-base support (Closes: #31163)
+
+ -- James LewisMoss <dres@debian.org> Sun, 22 Oct 2000 22:15:55 -0400
+
slib (2c7-1) unstable; urgency=low
* New upstream.
@@ -116,7 +160,4 @@ slib (2a6-1) unstable; urgency=low
-- Karl Sackett <krs@debian.org> Mon, 16 Dec 1996 09:23:46 -0600
-Local variables:
-mode: debian-changelog
-add-log-mailing-address: "dres@debian.org"
-End:
+
diff --git a/debian/control b/debian/control
index 3b3cde5..d4392b7 100644
--- a/debian/control
+++ b/debian/control
@@ -5,6 +5,8 @@ Maintainer: James LewisMoss <dres@debian.org>
Standards-Version: 3.0.0
Package: slib
+Section: devel
+Priority: optional
Architecture: all
Description: Portable Scheme library.
SLIB is a portable scheme library meant to provide compatibility and
diff --git a/debian/copyright b/debian/copyright
index 65247b2..2a18aa9 100644
--- a/debian/copyright
+++ b/debian/copyright
@@ -3,16 +3,474 @@ This is the Debian GNU/Linux prepackaged version of slib.
This package was put together by Rob Browning <rlb@cs.utexas.edu>
from sources obtained from:
- ftp://swiss-ftp.ai.mit.edu/archive/scm/slib2c0.tar.gz
+ ftp://swiss-ftp.ai.mit.edu/archive/scm/slib2d1.zip
For more information see:
http://www-swiss.ai.mit.edu/~jaffer/SLIB.html
-The source files are all subject to the following copyright:
+Following are a list of source files followed by the copyright that
+applies to them.
-; Copyright (C) 1991, 1992, 1993, 1994, 1997 Aubrey Jaffer.
+alist.scm alistab.scm arraymap.scm batch.scm break.scm Bev2slib.scm
+chap.scm charplot.scm cltime.scm coerce.scm comparse.scm cring.scm
+db2html.scm dbrowse.scm dbutil.scm debug.scm dwindtst.scm dynwind.scm
+eval.scm factor.scm fft.scm fluidlet.scm getopt.scm getparam.scm
+hash.scm hashtab.scm htmlform.scm http-cgi.scm lineio.scm logical.scm
+makcrc.scm mklibcat.scm modular.scm mulapply.scm nclients.scm
+obj2str.scm paramlst.scm plottest.scm pnm.scm ppfile.scm prec.scm
+printf.scm priorque.scm process.scm psxtime.scm qp.scm randinex.scm
+random.scm rdms.scm repl.scm report.scm require.scm root.scm sc2.scm
+sc4opt.scm sc4sc3.scm scanf.scm scmacro.scm simetrix.scm structst.scm
+tek40.scm tek41.scm timezone.scm trace.scm trnscrpt.scm tzfile.scm
+uri.scm withfile.scm
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of 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.scm formatst.scm Template.scm
+;;; "Template.scm" configuration template of *features* for Scheme -*-scheme-*-
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
+array.scm
+;;;;"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
+byte.scm determ.scm mularg.scm
+;; NO COPYRIGHT
+collect.scm
+;"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).
+comlist.scm
+;;"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.
+defmacex.scm
+;;;"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.
+dynamic.scm
+; "dynamic.scm", DYNAMIC data type for Scheme
+; Copyright 1992 Andrew Wilcox.
+;
+; You may freely copy, redistribute and modify this package.
+genwrite.scm
+;;"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
+glob.scm
+;;; "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.
+macrotst.scm
+;;;"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.
+macwork.scm mwdenote.scm mwexpand.scm mwsynrul.scm
+;;;; "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.
+mbe.scm
+;;;; "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.
+minimize.scm
+;;; "minimize.scm" finds minimum f(x) for x0 <= x <= x1.
+;;; Author: Lars Arvestad
+;;;
+;;; This code is in the public domain.
+object.scm
+;;; "object.scm" Macroless Object System
+;;;From: whumeniu@datap.ca (Wade Humeniuk)
+pp.scm
+;"pp.scm" Pretty-Print
+promise.scm
+;;;"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.
+queue.scm
+; "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.
+r4rsyn.scm synchk.scm synclo.scm synrul.scm
+;;; "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.
+ratize.scm
+;;;; "ratize.scm" Find simplest number ratios
+recobj.scm
+;;; "recobj.scm" Records implemented as objects.
+;;;From: whumeniu@datap.ca (Wade Humeniuk)
+record.scm
+; "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.
+scaexpp.scm scaglob.scm scainit.scm scamacr.scm scaoutp.scm structure.scm
+;;; "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.
+schmooz.scm
+;;; "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.
+scmactst.scm
+;;;"scmactst.scm" test syntactic closures macros
+;;; From "sc-macro.doc", A Syntactic Closures Macro Facility by Chris Hanson
+selfset.scm
+;;"selfset.scm" Set single letter identifiers to their symbols.
+sierpinski.scm
+;"sierpinski.scm" Hash function for 2d data which preserves nearness.
+;From: jjb@isye.gatech.edu (John Bartholdi)
+;
+; This code is in the public domain.
+sort.scm
+;;; "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.
+soundex.scm
+;"soundex.scm" Original SOUNDEX algorithm.
+;From jjb@isye.gatech.edu Mon May 2 22:29:43 1994
+;
+; This code is in the public domain.
+stdio.scm
+;; "stdio.scm" compatability stub
+strcase.scm
+;;; "strcase.scm" String casing functions.
+; Written 1992 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
+;
+; This code is in the public domain.
+strport.scm
+;;;;"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.
+strsrch.scm
+;;; "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.
+struct.scm
+;;; "struct.scm": defmacros for RECORDS
+;;; Copyright 1992 Jeff Alexander, Shinnder Lee, and Lewis Patterson
+tree.scm
+;;"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.
+tsort.scm
+;;; "tsort.scm" Topological sort
+;;; Copyright (C) 1995 Mikael Djurfeldt
+;
+; This code is in the public domain.
+values.scm
+;"values.scm" multiple values
+;By david carlton, carlton@husc.harvard.edu.
;
+;This code is in the public domain.
+wttest.scm
+;; "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.
+wttree.scm
+;; "wttree.scm" Weight balanced trees -*-Scheme-*-
+;; Copyright (c) 1993-1994 Stephen Adams
+;;
+;; $Id: wttree.scm,v 1.3 1999/10/11 03:36:29 jaffer 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.
+yasyn.scm
+;;"yasyn.scm" YASOS in terms of "object.scm"
+;;;From: whumeniu@datap.ca (Wade Humeniuk)
+DrScheme.init
+;;;"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
+RScheme.init
+;;;"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.
@@ -27,4 +485,95 @@ The source files are all subject to the following copyright:
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
-;each case.
+;each case.
+STk.init
+;;;"STk.init" SLIB Initialization for STk -*-scheme-*-
+;;; Authors: Erick Gallesio (eg@unice.fr) and Aubrey Jaffer.
+;;;
+;;; This code is in the public domain.
+bigloo.init
+;; "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.
+chez.init
+;;;"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.
+elk.init
+;;;"elk.init" Initialisation file for SLIB for ELK 2.1 -*- Scheme -*-
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
+gambit.init
+;;;"gambit.init" Initialization for SLIB for Gambit -*-scheme-*-
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
+macscheme.init
+;;;"macscheme.init" Configuration of *features* for MacScheme -*-scheme-*-
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
+mitscheme.init
+;;;"mitscheme.init" Initialization for SLIB for MITScheme -*-scheme-*-
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
+pscheme.init
+;;; "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.
+scheme2c.init
+;;; "scheme2c.init" Initialisation for SLIB for Scheme->C on Sun -*-scheme-*-
+;;; Authors: David Love and Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
+scheme48.init
+;;;"scheme48.init" Initialisation for SLIB for Scheme48 -*-scheme-*-
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
+scm.init
+;"scm.init" Configuration file for SLIB for SCM -*-scheme-*-
+scsh.init
+;;; "scsh.init" Initialisation for SLIB for Scsh 0.5.1 -*-scheme-*-
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
+t3.init
+;;; "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.
+umbscheme.init
+;;; "umbscheme.init" Initialization for SLIB for umb-scheme -*-scheme-*-
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
+vscm.init
+;;; "vscm.init" Configuration of *features* for VSCM -*-scheme-*-
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
diff --git a/debian/doc-base b/debian/doc-base
new file mode 100644
index 0000000..72e6327
--- /dev/null
+++ b/debian/doc-base
@@ -0,0 +1,15 @@
+Document: slib
+Title: slib Scheme library documentation
+Author: Aubrey Jaffer
+Abstract: This manual describes the facilities and functions
+ provided by the slib scheme library.
+Section: Apps/Programming
+
+Format: Info
+Section: The Algorithmic Language Scheme
+Index: /usr/share/info/slib.info.gz
+Files: /usr/share/info/slib.info.gz
+
+Format: HTML
+Index: /usr/share/doc/slib/slib.html
+Files: /usr/share/doc/slib/slib.html
diff --git a/debian/postinst b/debian/postinst
index 2e719ac..847a44a 100644
--- a/debian/postinst
+++ b/debian/postinst
@@ -1,13 +1,19 @@
#!/bin/sh
set -e
-install-info --quiet --section "Development" "Development" \
+install-info --quiet --section "The Algorithmic Language Scheme" \
+ "The Algorithmic Language Scheme" \
--description="The SLIB portable Scheme library" \
/usr/share/info/slib.info.gz
-# OK. This is bad because it really should be in the guile config or in some
-# emacs-commond sort of package.
-#/usr/sbin/slibconfig
+# OK. This is bad because it really should be in the guile config or
+# in some emacs-commond sort of package. Now we conditionally run it.
+# one of these probably shouldn't exist, but don't know which and
+# probably shourld support the older.
+if [ -x /usr/sbin/guile1.4-slibconfig ] ; then
+ echo Running /usr/sbin/guile1.4-slibconfig
+ /usr/sbin/guile1.4-slibconfig
+fi
if [ "$1" = "configure" ]; then
if [ -d /usr/doc -a ! -e /usr/doc/slib -a -d /usr/share/doc/slib ]; then
@@ -15,3 +21,9 @@ if [ "$1" = "configure" ]; then
fi
fi
+# doc base support
+if [ "$1" = configure ]; then
+ if command -v install-docs >/dev/null 2>&1; then
+ install-docs -i /usr/share/doc-base/slib
+ fi
+fi
diff --git a/debian/postrm b/debian/postrm
deleted file mode 100644
index abf12d1..0000000
--- a/debian/postrm
+++ /dev/null
@@ -1,5 +0,0 @@
-#!/bin/sh
-set -e
-
-install-info --quiet --remove slib
-
diff --git a/debian/prerm b/debian/prerm
index 853a5c4..3dbde02 100644
--- a/debian/prerm
+++ b/debian/prerm
@@ -6,3 +6,11 @@ if [ \( "$1" = "upgrade" -o "$1" = "remove" \) -a -L /usr/doc/slib ]; then
rm -f /usr/doc/slib
fi
+# doc base support
+if [ "$1" = remove -o "$1" = upgrade ]; then
+ if command -v install-docs >/dev/null 2>&1; then
+ install-docs -r slib
+ fi
+fi
+
+install-info --quiet --remove /usr/share/info/slib.info.gz
diff --git a/debian/rules b/debian/rules
index 1a8c9a9..f690acd 100755
--- a/debian/rules
+++ b/debian/rules
@@ -40,7 +40,6 @@ binary-indep: checkroot build
$(INSTALL_DIR) debian/tmp/DEBIAN
$(INSTALL_PROGRAM) debian/postinst debian/tmp/DEBIAN
$(INSTALL_PROGRAM) debian/prerm debian/tmp/DEBIAN
- $(INSTALL_PROGRAM) debian/postrm debian/tmp/DEBIAN
# library
$(INSTALL_DIR) debian/tmp/usr/share/slib
@@ -66,6 +65,9 @@ binary-indep: checkroot build
$(INSTALL_DIR) debian/tmp/usr/share/slib/init
$(INSTALL_DATA) *.init debian/tmp/usr/share/slib/init
+ $(INSTALL_DIR) debian/tmp/usr/share/doc-base
+ $(INSTALL_DATA) debian/doc-base debian/tmp/usr/share/doc-base/slib
+
# info pages
$(INSTALL_DIR) debian/tmp/usr/share/info
$(INSTALL_DATA) slib.info* debian/tmp/usr/share/info
@@ -73,10 +75,10 @@ binary-indep: checkroot build
# slibconfig
- $(INSTALL_DIR) debian/tmp/usr/sbin
- $(INSTALL_PROGRAM) debian/slibconfig debian/tmp/usr/sbin
+ #$(INSTALL_DIR) debian/tmp/usr/sbin
+ #$(INSTALL_PROGRAM) debian/slibconfig debian/tmp/usr/sbin
- dpkg-gencontrol
+ dpkg-gencontrol -is -ip
dpkg --build debian/tmp ..
define checkdir
diff --git a/debug.scm b/debug.scm
index 58f6b03..0a913b4 100644
--- a/debug.scm
+++ b/debug.scm
@@ -1,9 +1,9 @@
;;;; "debug.scm" Utility functions for debugging in Scheme.
-;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -40,11 +40,9 @@
(if (list? (car exp)) exp (cdr exp))))
(cdr exp)))
((if) (for-each
- walk
- (if (list? (cadr exp)) (cdr exp) (cddr exp))))
- ((defmacro define-syntax) "should do something clever here")
- ((define)
- (proc exp))))))))
+ 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)))
@@ -59,22 +57,42 @@
form))))
(for-each-top-level-definition-in-file
file
- (lambda (form) (let ((sym (get-defined-symbol (cadr form))))
- (cond ((procedure? (slib:eval sym))
- (proc sym))))))))
+ (lambda (form)
+ (and (eqv? 'define (car form))
+ (let ((sym (get-defined-symbol (cadr form))))
+ (cond ((procedure? (slib:eval sym))
+ (proc sym)))))))))
-(define (debug:trace-all file)
- (for-each-top-level-defined-procedure-symbol-in-file
- file
- (lambda (sym)
- (slib:eval `(set! ,sym (trace:tracef ,sym ',sym))))))
-
-(define trace-all debug:trace-all)
-
-(define (debug:break-all file)
- (for-each-top-level-defined-procedure-symbol-in-file
- file
- (lambda (sym)
- (slib:eval `(set! ,sym (break:breakf ,sym ',sym))))))
+(define (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 debug:break-all)
+(define (break-all file . ...)
+ (for-each
+ (lambda (file)
+ (for-each-top-level-defined-procedure-symbol-in-file
+ file
+ (lambda (sym)
+ (slib:eval `(set! ,sym (break:breakf ,sym ',sym))))))
+ (cons file ...)))
diff --git a/defmacex.scm b/defmacex.scm
index bdaf020..5863c94 100644
--- a/defmacex.scm
+++ b/defmacex.scm
@@ -1,9 +1,9 @@
;;;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -92,5 +92,9 @@
(cadr e))
,(map defmacro:expand* (caddr e))
,@(map defmacro:expand* (cdddr e))))
+ ((defmacro)
+ (cons (car e)
+ (cons (cadr e)
+ (cons (caddr e) (map defmacro:expand* (cdddr e))))))
(else (map defmacro:expand* e)))))
e))
diff --git a/differ.scm b/differ.scm
new file mode 100644
index 0000000..53e0eaf
--- /dev/null
+++ b/differ.scm
@@ -0,0 +1,222 @@
+;;;; "differ.scm" O(NP) Sequence Comparison Algorithm.
+;;; Copyright (C) 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;@noindent
+;;This package implements the algorithm:
+;;
+;;@ifinfo
+;;@example
+;;S. Wu, E. Myers, U. Manber, and W. Miller,
+;; "An O(NP) Sequence Comparison Algorithm,"
+;; Information Processing Letters 35, 6 (1990), 317-323.
+;; @url{http://www.cs.arizona.edu/people/gene/vita.html}
+;;@end example
+;;@end ifinfo
+;;@ifset html
+;;S. Wu, <A HREF="http://www.cs.arizona.edu/people/gene/vita.html">
+;;E. Myers,</A> U. Manber, and W. Miller,
+;;<A HREF="http://www.cs.arizona.edu/people/gene/PAPERS/np_diff.ps">
+;;"An O(NP) Sequence Comparison Algorithm,"</A>
+;;Information Processing Letters 35, 6 (1990), 317-323.
+;;@end ifset
+;;
+;;@noindent
+;;If the items being sequenced are text lines, then the computed
+;;edit-list is equivalent to the output of the @dfn{diff} utility
+;;program. If the items being sequenced are words, then it is like the
+;;lesser known @dfn{spiff} program.
+;;
+;;@noindent
+;;The values returned by @code{diff:edit-length} can be used to gauge
+;;the degree of match between two sequences.
+;;
+;;@noindent
+;;I believe that this algorithm is currently the fastest for these
+;;tasks, but genome sequencing applications fuel extensive research in
+;;this area.
+
+(require 'array)
+
+(define (fp:compare fp Delta snake len2)
+ (let loop ((p 0))
+ (do ((k (- p) (+ 1 k)))
+ ((> k (+ -1 Delta)))
+ (array-set! fp (snake k (max (+ 1 (array-ref fp (+ -1 k)))
+ (array-ref fp (+ 1 k))))
+ k))
+ (do ((k (+ Delta p) (+ -1 k)))
+ ((< k (+ 1 Delta)))
+ (array-set! fp (snake k (max (+ 1 (array-ref fp (+ -1 k)))
+ (array-ref fp (+ 1 k))))
+ k))
+ (array-set! fp (snake Delta (max (+ 1 (array-ref fp (+ -1 Delta)))
+ (array-ref fp (+ 1 Delta))))
+ Delta)
+ (if (= (array-ref fp Delta) len2)
+ (+ Delta (* 2 p))
+ (loop (+ 1 p)))))
+
+(define (fp->edits fp Delta)
+ (let loop ((idx (+ -1 Delta))
+ (ddx (+ 1 Delta))
+ (edits '()))
+ (define ivl (array-ref fp idx))
+ (define dvl (array-ref fp ddx))
+ (if (not (= -1 dvl)) (set! dvl (- dvl ddx)))
+ ;;(print idx '-> ivl ddx '-> dvl)
+ (cond ((= ivl -1) edits)
+ ((= dvl -1) (loop (+ -1 idx) ddx (cons (list ivl 'insert) edits)))
+ ((> dvl ivl) (loop idx (+ 1 ddx) (cons (list dvl 'delete) edits)))
+ (else (loop (+ -1 idx) ddx (cons (list ivl 'insert) edits))))))
+
+(define (fp->lcs fp Delta array1 len)
+ (define len1 (car (array-dimensions array1)))
+ (define lcs (make-array #f len))
+ (define (subarray-copy! array1 start1 end1 array2 start2)
+ (do ((i start1 (+ i 1))
+ (j start2 (+ j 1))
+ (l (- end1 start1) (- l 1)))
+ ((<= l 0))
+ (array-set! array2 (array-ref array1 i) j)))
+ (let loop ((ddx (+ 1 Delta))
+ (pos len1)
+ (dpos len))
+ (let* ((dvl (array-ref fp ddx))
+ (sublen (- pos (- dvl ddx -1))))
+ (cond ((= dvl -1)
+ (subarray-copy! array1 0 pos lcs 0)
+ lcs)
+ (else
+ (subarray-copy! array1 (- dvl ddx -1) pos lcs (- dpos sublen))
+ (loop (+ 1 ddx) (- dvl ddx) (- dpos sublen)))))))
+
+;;@args array1 array2 =?
+;;@args array1 array2
+;;@1 and @2 are one-dimensional arrays. The procedure @3 is used
+;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}.
+;;@0 returns a one-dimensional array of length @code{(quotient (- (+
+;;len1 len2) (fp:edit-length @1 @2)) 2)} holding the longest sequence
+;;common to both @var{array}s.
+(define (diff:longest-common-subsequence array1 array2 . =?)
+ (define len1 (car (array-dimensions array1)))
+ (define len2 (car (array-dimensions array2)))
+ (define (snake k y)
+ (let snloop ((x (- y k))
+ (y y))
+ (if (and (< x len1) (< y len2) (=? (array-ref array1 x)
+ (array-ref array2 y)))
+ (snloop (+ 1 x) (+ 1 y))
+ y)))
+ (set! =? (if (null? =?) eqv? (car =?)))
+ (if (> len1 len2)
+ (diff:longest-common-subsequence array2 array1)
+ (let ((Delta (- len2 len1))
+ (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2)))))
+ (fp->lcs fp Delta array1
+ (quotient (- (+ len1 len2) (fp:compare fp Delta snake len2))
+ 2)))))
+
+;;@args array1 array2 =?
+;;@args array1 array2
+;;@1 and @2 are one-dimensional arrays. The procedure @3 is used
+;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}.
+;;@0 returns a list of length @code{(fp:edit-length @1 @2)} composed of
+;;a shortest sequence of edits transformaing @1 to @2.
+;;
+;;Each edit is a list of an integer and a symbol:
+;;@table @asis
+;;@item (@var{j} insert)
+;;Inserts @code{(array-ref @1 @var{j})} into the sequence.
+;;@item (@var{k} delete)
+;;Deletes @code{(array-ref @2 @var{k})} from the sequence.
+;;@end table
+(define (diff:edits array1 array2 . =?)
+ (define len1 (car (array-dimensions array1)))
+ (define len2 (car (array-dimensions array2)))
+ (define (snake k y)
+ (let snloop ((x (- y k))
+ (y y))
+ (if (and (< x len1) (< y len2) (=? (array-ref array1 x)
+ (array-ref array2 y)))
+ (snloop (+ 1 x) (+ 1 y)) y)))
+ (set! =? (if (null? =?) eqv? (car =?)))
+ (if (> len1 len2)
+ (diff:reverse-edits (diff:edits array2 array1))
+ (let ((Delta (- len2 len1))
+ (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2)))))
+ (fp:compare fp Delta snake len2)
+ ;;(do ((idx (- -1 len1) (+ 1 idx))) ((>= idx (+ 1 len2)) (newline)) (printf "%3d" idx))
+ ;;(do ((idx (- -1 len1) (+ 1 idx))) ((>= idx (+ 1 len2)) (newline)) (printf "%3d" (array-ref fp idx)))
+ (fp->edits fp Delta))))
+
+(define (diff:reverse-edits edits)
+ (map (lambda (edit)
+ (list (car edit)
+ (case (cadr edit)
+ ((delete) 'insert)
+ ((insert) 'delete))))
+ edits))
+
+;;@args array1 array2 =?
+;;@args array1 array2
+;;@1 and @2 are one-dimensional arrays. The procedure @3 is used
+;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}.
+;;@0 returns the length of the shortest sequence of edits transformaing
+;;@1 to @2.
+(define (diff:edit-length array1 array2 . =?)
+ (define len1 (car (array-dimensions array1)))
+ (define len2 (car (array-dimensions array2)))
+ (define (snake k y)
+ (let snloop ((x (- y k))
+ (y y))
+ (if (and (< x len1) (< y len2) (=? (array-ref array1 x)
+ (array-ref array2 y)))
+ (snloop (+ 1 x) (+ 1 y))
+ y)))
+ (set! =? (if (null? =?) eqv? (car =?)))
+ (if (> len1 len2)
+ (diff:edit-length array2 array1)
+ (let ((Delta (- len2 len1))
+ (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2)))))
+ (fp:compare fp Delta snake len2))))
+
+;;@example
+;;(diff:longest-common-subsequence '#(f g h i e j c k l m)
+;; '#(f g e h i j k p q r l m))
+;; @result{} #(f g h i j k l m)
+;;
+;;(diff:edit-length '#(f g h i e j c k l m)
+;; '#(f g e h i j k p q r l m))
+;;@result{} 6
+;;
+;;(pretty-print (diff:edits '#(f g h i e j c k l m)
+;; '#(f g e h i j k p q r l m)))
+;;@print{}
+;;((3 insert) ; e
+;; (4 delete) ; c
+;; (6 delete) ; h
+;; (7 insert) ; p
+;; (8 insert) ; q
+;; (9 insert)) ; r
+;;@end example
+
+;; 12 - 10 = 2
+;; -11-10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12
+;; -1 -1 -1 -1 -1 -1 -1 -1 -1 3 7 8 9 12 9 8 -1 -1 -1 -1 -1 -1 -1 -1
+;; edit-distance = 6
diff --git a/differ.txi b/differ.txi
new file mode 100644
index 0000000..f7b1f75
--- /dev/null
+++ b/differ.txi
@@ -0,0 +1,95 @@
+@noindent
+This package implements the algorithm:
+
+@ifinfo
+@example
+S. Wu, E. Myers, U. Manber, and W. Miller,
+ "An O(NP) Sequence Comparison Algorithm,"
+ Information Processing Letters 35, 6 (1990), 317-323.
+ @url{http://www.cs.arizona.edu/people/gene/vita.html}
+@end example
+@end ifinfo
+@ifset html
+S. Wu, <A HREF="http://www.cs.arizona.edu/people/gene/vita.html">
+E. Myers,</A> U. Manber, and W. Miller,
+<A HREF="http://www.cs.arizona.edu/people/gene/PAPERS/np_diff.ps">
+"An O(NP) Sequence Comparison Algorithm,"</A>
+Information Processing Letters 35, 6 (1990), 317-323.
+@end ifset
+
+@noindent
+If the items being sequenced are text lines, then the computed
+edit-list is equivalent to the output of the @dfn{diff} utility
+@cindex diff
+program. If the items being sequenced are words, then it is like the
+lesser known @dfn{spiff} program.
+@cindex spiff
+
+@noindent
+The values returned by @code{diff:edit-length} can be used to gauge
+the degree of match between two sequences.
+
+@noindent
+I believe that this algorithm is currently the fastest for these
+tasks, but genome sequencing applications fuel extensive research in
+this area.
+
+
+@defun diff:longest-common-subsequence array1 array2 =?
+
+
+@defunx diff:longest-common-subsequence array1 array2
+@var{array1} and @var{array2} are one-dimensional arrays. The procedure @var{=?} is used
+to compare sequence tokens for equality. @var{=?} defaults to @code{eqv?}.
+@code{diff:longest-common-subsequence} returns a one-dimensional array of length @code{(quotient (- (+
+len1 len2) (fp:edit-length @var{array1} @var{array2})) 2)} holding the longest sequence
+common to both @var{array}s.
+@end defun
+
+@defun diff:edits array1 array2 =?
+
+
+@defunx diff:edits array1 array2
+@var{array1} and @var{array2} are one-dimensional arrays. The procedure @var{=?} is used
+to compare sequence tokens for equality. @var{=?} defaults to @code{eqv?}.
+@code{diff:edits} returns a list of length @code{(fp:edit-length @var{array1} @var{array2})} composed of
+a shortest sequence of edits transformaing @var{array1} to @var{array2}.
+
+Each edit is a list of an integer and a symbol:
+@table @asis
+@item (@var{j} insert)
+Inserts @code{(array-ref @var{array1} @var{j})} into the sequence.
+@item (@var{k} delete)
+Deletes @code{(array-ref @var{array2} @var{k})} from the sequence.
+@end table
+@end defun
+
+@defun diff:edit-length array1 array2 =?
+
+
+@defunx diff:edit-length array1 array2
+@var{array1} and @var{array2} are one-dimensional arrays. The procedure @var{=?} is used
+to compare sequence tokens for equality. @var{=?} defaults to @code{eqv?}.
+@code{diff:edit-length} returns the length of the shortest sequence of edits transformaing
+@var{array1} to @var{array2}.
+@end defun
+@example
+(diff:longest-common-subsequence '#(f g h i e j c k l m)
+ '#(f g e h i j k p q r l m))
+ @result{} #(f g h i j k l m)
+
+(diff:edit-length '#(f g h i e j c k l m)
+ '#(f g e h i j k p q r l m))
+@result{} 6
+
+(pretty-print (diff:edits '#(f g h i e j c k l m)
+ '#(f g e h i j k p q r l m)))
+@print{}
+((3 insert) ; e
+ (4 delete) ; c
+ (6 delete) ; h
+ (7 insert) ; p
+ (8 insert) ; q
+ (9 insert)) ; r
+@end example
+
diff --git a/dwindtst.scm b/dwindtst.scm
index 8d64800..868901e 100644
--- a/dwindtst.scm
+++ b/dwindtst.scm
@@ -1,9 +1,9 @@
;;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/dynwind.scm b/dynwind.scm
index 9212422..c9bdb95 100644
--- a/dynwind.scm
+++ b/dynwind.scm
@@ -1,9 +1,9 @@
; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/elk.init b/elk.init
index 5acda43..598b935 100644
--- a/elk.init
+++ b/elk.init
@@ -24,8 +24,8 @@
(define (scheme-implementation-type) 'Elk)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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)
@@ -81,23 +81,66 @@
;(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
+
+ ;; Scheme report features
+
+; rev5-report ;conforms to
+; eval ;R5RS two-argument eval
+; values ;R5RS multiple values
+; dynamic-wind ;R5RS dynamic-wind
+; macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+; char-ready?
+; rationalize
+ rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
+ ;LIST->STRING, STRING-COPY,
+ ;STRING-FILL!, LIST->VECTOR,
+ ;VECTOR->LIST, and VECTOR-FILL!
+
+ rev4-report ;conforms to
+
+ ieee-p1178 ;conforms to
+
+; rev3-report ;conforms to
+
+ rev2-procedures ;SUBSTRING-MOVE-LEFT!,
+ ;SUBSTRING-MOVE-RIGHT!,
+ ;SUBSTRING-FILL!,
+ ;STRING-NULL?, APPEND!, 1+,
+ ;-1+, <?, <=?, =?, >?, >=?
+; object-hash ;has OBJECT-HASH
+
+ multiarg/and- ;/ and - can take more than 2 args.
+; with-file ;has WITH-INPUT-FROM-FILE and
+ ;WITH-OUTPUT-FROM-FILE
+ transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
+; ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
+ full-continuation ;can return multiple times
+
+ ;; Other common features
+
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
+ sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+; defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+ string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
sort
- format
- system
- getenv
- program-arguments
- string-port
+; pretty-print
+; object->string
+ format ;Common-lisp output formatting
+; 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)
+; current-time ;returns time in seconds since 1/1/1970
))
;------------
@@ -222,13 +265,17 @@
(define slib:warn
(lambda args
- (let ((port (current-error-port)))
- (display "Warn: " port)
- (for-each (lambda (x) (display x port)) 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))
diff --git a/eval.scm b/eval.scm
index cc4b816..a5e7e19 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1,9 +1,9 @@
; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/factor.scm b/factor.scm
index f10f0d5..3b9fb5e 100644
--- a/factor.scm
+++ b/factor.scm
@@ -1,9 +1,9 @@
;;;; "factor.scm" factorization, prime test and generation
-;;; Copyright (C) 1991, 1992, 1993, 1998 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/factor.txi b/factor.txi
index 8277c2b..38c0dd1 100644
--- a/factor.txi
+++ b/factor.txi
@@ -1,73 +1,56 @@
-
-
@defvar prime:prngs
- @var{prime:prngs} is the random-state (@pxref{Random Numbers}) used by these
- procedures. If you call these procedures from more than one thread
- (or from interrupt), @code{random} may complain about reentrant
- calls.
+@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}.
+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.
+@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}.
+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.
+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}.
+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}) <)}.
+Returns a list of the prime factors of @var{k}. The order of the
+factors is unspecified. In order to obtain a sorted list do
+@code{(sort! (factor @var{k}) <)}.
@end defun
diff --git a/fft.scm b/fft.scm
index 0936c1c..9537e9c 100644
--- a/fft.scm
+++ b/fft.scm
@@ -1,9 +1,9 @@
;;;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/fluidlet.scm b/fluidlet.scm
index 59ba481..983bfdb 100644
--- a/fluidlet.scm
+++ b/fluidlet.scm
@@ -1,9 +1,9 @@
; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/fmtdoc.txi b/fmtdoc.txi
index 40064f0..3e2adb7 100644
--- a/fmtdoc.txi
+++ b/fmtdoc.txi
@@ -136,7 +136,7 @@ print a number as a Roman numeral.
print a number as an ``old fashioned'' Roman numeral.
@item @code{~:R}
print a number as an ordinal English number.
-@item @code{~:@@R}
+@item @code{~R}
print a number as a cardinal English number.
@item @code{~P}
Plural.
diff --git a/format.scm b/format.scm
index d9f1c86..709acf7 100644
--- a/format.scm
+++ b/format.scm
@@ -13,6 +13,7 @@
(provide 'format)
(require 'string-case)
(require 'string-port)
+(require 'multiarg/and-)
(require 'rev4-optional-procedures)
;;; Configuration ------------------------------------------------------------
diff --git a/gambit.init b/gambit.init
index 45dd4e2..538fb47 100644
--- a/gambit.init
+++ b/gambit.init
@@ -3,6 +3,9 @@
;;;
;;; This code is in the public domain.
+;;; Ignore case when reading symbols (per R5RS).
+(set-case-conversion! #t)
+
;;; 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)
@@ -14,8 +17,8 @@
(define (scheme-implementation-type) 'gambit)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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)
@@ -83,6 +86,7 @@
rev4-report ;conforms to
; rev3-report ;conforms to
ieee-p1178 ;conforms to
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
@@ -101,7 +105,7 @@
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
+ string-port ;has CALL-WITH-INPUT-STRING and
;CALL-WITH-OUTPUT-STRING
transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
char-ready?
@@ -115,7 +119,6 @@
; object-hash ;has OBJECT-HASH
; sort
-; queue ;queues
pretty-print
; object->string
; format
@@ -125,10 +128,6 @@
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
))
@@ -164,6 +163,13 @@
;;; 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)
@@ -237,12 +243,15 @@
(define slib:warn
(lambda args
- (let ((port (current-error-port)))
- (display "Warn: " port)
- (for-each (lambda (x) (display x port)) 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 error)
+(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))
diff --git a/genwrite.scm b/genwrite.scm
index 0bb4e56..2e4bf60 100644
--- a/genwrite.scm
+++ b/genwrite.scm
@@ -3,13 +3,15 @@
;; 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))
+ ((quote quasiquote unquote unquote-splicing) (length1? tail))
(else #f))))
(define (read-macro-body l)
@@ -18,10 +20,10 @@
(define (read-macro-prefix l)
(let ((head (car l)) (tail (cdr l)))
(case head
- ((QUOTE) "'")
- ((QUASIQUOTE) "`")
- ((UNQUOTE) ",")
- ((UNQUOTE-SPLICING) ",@"))))
+ ((quote) "'")
+ ((quasiquote) "`")
+ ((unquote) ",")
+ ((unquote-splicing) ",@"))))
(define (out str col)
(and col (output str) (+ col (string-length str))))
@@ -90,7 +92,7 @@
(define (indent to col)
(and col
(if (< to col)
- (and (out (make-string 1 #\newline) col) (spaces to 0))
+ (and (out genwrite:newline-str col) (spaces to 0))
(spaces (- to col) col))))
(define (pr obj col extra pp-pair)
@@ -228,20 +230,20 @@
(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)
+ ((lambda let* letrec define) pp-LAMBDA)
+ ((if set!) pp-IF)
+ ((cond) pp-COND)
+ ((case) pp-CASE)
+ ((and or) pp-AND)
+ ((let) pp-LET)
+ ((begin) pp-BEGIN)
+ ((do) pp-DO)
(else #f)))
(pr obj col 0 pp-expr))
(if width
- (out (make-string 1 #\newline) (pp obj 0))
+ (out genwrite:newline-str (pp obj 0))
(wr obj 0)))
; (reverse-string-append l) = (apply string-append (reverse l))
diff --git a/getopt.scm b/getopt.scm
index c2962db..bb0b8a8 100644
--- a/getopt.scm
+++ b/getopt.scm
@@ -1,9 +1,9 @@
;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/getparam.scm b/getparam.scm
index ad4baba..3e2d7f1 100644
--- a/getparam.scm
+++ b/getparam.scm
@@ -1,9 +1,9 @@
;;; "getparam.scm" convert getopt to passing parameters by name.
-; Copyright 1995, 1996, 1997 Aubrey Jaffer
+; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -18,39 +18,78 @@
;each case.
(require 'getopt)
+(require 'coerce)
-(define (getopt->parameter-list argc argv optnames arities types aliases)
+(define (getopt->parameter-list argc argv optnames arities types aliases
+ . description)
(define (can-take-arg? opt)
- (not (eq? (list-ref arities (position opt optnames))
- 'boolean)))
- (define (coerce-val val curopt)
- (define ntyp (list-ref types (position curopt optnames)))
- (case ntyp
- ((expression) val)
- (else (coerce val ntyp))))
- (let ((starting-optind *optind*)
+ (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*))
- (set! aliases (map (lambda (alias)
- (define str (string-copy (car alias)))
- (do ((i (+ -1 (string-length str)) (+ -1 i)))
- ((negative? i) (cons str (cdr alias)))
- (cond ((char=? #\ (string-ref str i))
- (string-set! str i #\-)))))
- aliases))
+ (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 ((not (string? opt)))
+ (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))))
+ (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)))
@@ -58,50 +97,52 @@
(let ((opt (getopt-- argc argv optstring)))
(case opt
((#\: #\?)
- (parameter-list->getopt-usage (list-ref argv (+ -1 starting-optind))
- optnames arities types aliases)
- (slib:error 'getopt->parameter-list
- (case opt
- ((#\:) "argument missing after")
- ((#\?) "unrecognized option"))
- (string #\- getopt: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*)))
+ (set! *optind* (+ 1 *optind*))
+ (finish))
((< *optind* argc)
- (cond ((and (member curopt optnames)
- (adjoin-parameters!
- parameter-list
- (list curopt
- (coerce-val (list-ref argv *optind*)
- curopt))))
- (set! *optind* (+ 1 *optind*))
- (loop))
- (else (slib:error 'getopt->parameter-list curopt
- (list-ref argv *optind*)
- "not supported"))))))
+ (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)))
- (cond (topt (set! topt (cadr topt)))
- (else (slib:error "Option not recognized -" opt)))
+ (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)))
- (*optarg*
- (set! curopt topt)
- (adjoin-parameters! parameter-list
- (list topt (coerce-val *optarg* curopt))))
+ (adjoin-parameters! parameter-list (list topt #t))
+ (loop))
+ (*optarg* (set! curopt topt) (adjoin-val *optarg* curopt) (loop))
(else
- (set! curopt topt)
-;;; (slib:warn 'getopt->parameter-list
-;;; "= missing for option--" opt)
- )))
- (loop)))))
- parameter-list))
+;;; (slib:warn 'getopt->parameter-list "= missing for option--" opt)
+ (set! curopt topt) (loop))))))))))
-(define (parameter-list->getopt-usage comname optnames arities types aliases)
+(define (parameter-list->getopt-usage comname optnames arities types aliases
+ . description)
(require 'printf)
(require 'common-list-functions)
(let ((aliast (map list optnames))
@@ -112,16 +153,29 @@
(set-cdr! apr (cons (car alias) (cdr apr)))))
aliases)
(fprintf cep "Usage: %s [OPTION ARGUMENT ...] ..." comname)
- (newline cep) (newline cep)
+ (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? (cdr aliat)))
- (longname (remove-if strlen=1? (cdr 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")
- (else " %3s %s<%s> %s"))
+ ((boolean) " %3s %s\\n")
+ (else " %3s %s<%s> %s\\n"))
(if (null? initials)
""
(string-append "-" (car initials)
@@ -138,15 +192,22 @@
(case arity
((nary nary1) "...")
(else "")))
- (newline cep)
(loop (if (null? initials) '() (cdr initials))
(if (null? longname) '() (cdr longname)))))))
- optnames arities aliast)))
+ 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)
- (let* ((params (getopt->parameter-list
- argc argv optnames arities types aliases))
- (fparams (fill-empty-parameters defaulters params)))
- (and (list? params) (check-parameters checks fparams))
- (and (list? params) (parameter-list->arglist positions arities fparams))))
+ arities types defaulters checks aliases . description)
+ (define progname (list-ref argv (+ -1 *optind*)))
+ (let* ((params (apply getopt->parameter-list
+ argc argv optnames arities types aliases description))
+ (fparams (and params (fill-empty-parameters defaulters params))))
+ (cond ((and (list? params)
+ (check-parameters checks fparams)
+ (parameter-list->arglist positions arities fparams)))
+ (params (apply parameter-list->getopt-usage
+ progname optnames arities types aliases description))
+ (else #f))))
+
diff --git a/glob.scm b/glob.scm
index 0029243..d6e993b 100644
--- a/glob.scm
+++ b/glob.scm
@@ -1,9 +1,9 @@
;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -17,9 +17,6 @@
;promotional, or sales literature without prior written consent in
;each case.
-;;$Header: /usr/local/cvsroot/slib/glob.scm,v 1.15 1999/11/01 01:37:08 jaffer Exp $
-;;$Name: $
-
(define (glob:pattern->tokens pat)
(cond
((string? pat)
diff --git a/guile.init b/guile.init
new file mode 100644
index 0000000..897a28a
--- /dev/null
+++ b/guile.init
@@ -0,0 +1,4 @@
+;"guile.init" Configuration file for SLIB for GUILE -*-scheme-*-
+
+(use-modules (ice-9 slib))
+(define (slib:load-cadr argv) (slib:load (cadr argv)))
diff --git a/hash.scm b/hash.scm
index ab02138..e53d518 100644
--- a/hash.scm
+++ b/hash.scm
@@ -1,9 +1,9 @@
; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/hashtab.scm b/hashtab.scm
index 317efe2..de46d47 100644
--- a/hashtab.scm
+++ b/hashtab.scm
@@ -1,9 +1,9 @@
; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/htmlform.scm b/htmlform.scm
index 02dc63a..935e006 100644
--- a/htmlform.scm
+++ b/htmlform.scm
@@ -1,9 +1,9 @@
-;;; "htmlform.scm" Generate HTML 2.0 forms; service CGI requests. -*-scheme-*-
-; Copyright 1997, 1998 Aubrey Jaffer
+;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -18,31 +18,20 @@
;each case.
(require 'sort)
-(require 'scanf)
(require 'printf)
-(require 'line-i/o)
(require 'parameters)
-(require 'fluid-let)
-(require 'dynamic-wind)
-(require 'pretty-print)
(require 'object->string)
-(require 'string-case)
-(require 'string-port)
(require 'string-search)
(require 'database-utilities)
(require 'common-list-functions)
;;;;@code{(require 'html-form)}
-
-;;@body Procedure names starting with @samp{html:} send their output
-;;to the port @0. @0 is initially the current output port.
-(define *html:output-port* (current-output-port))
-
-(define (html:printf . args) (apply fprintf *html:output-port* args))
+;;@ftindex html-form
+(define html:blank (string->symbol ""))
;;@body Returns a string with character substitutions appropriate to
;;send @1 as an @dfn{attribute-value}.
-(define (make-atval txt) ; attribute-value
+(define (html:atval txt) ; attribute-value
(if (symbol? txt) (set! txt (symbol->string txt)))
(if (number? txt)
(number->string txt)
@@ -54,256 +43,164 @@
;;@body Returns a string with character substitutions appropriate to
;;send @1 as an @dfn{plain-text}.
-(define (make-plain txt) ; plain-text `Data Characters'
- (if (symbol? txt) (set! txt (symbol->string txt)))
- (if (number? txt)
- (number->string txt)
- (string-subst (if (string? txt) txt (object->string txt))
- "&" "&amp;"
- "<" "&lt;"
- ">" "&gt;")))
+(define (html:plain txt) ; plain-text `Data Characters'
+ (cond ((eq? html:blank txt) "&nbsp;")
+ (else
+ (if (symbol? txt) (set! txt (symbol->string txt)))
+ (if (number? txt)
+ (number->string txt)
+ (string-subst (if (string? txt) txt (object->string txt))
+ "&" "&amp;"
+ "<" "&lt;"
+ ">" "&gt;")))))
+
+;;@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
;;
-;;Outputs headers for an HTML page named @1. If string arguments @2
-;;... are supplied they are printed verbatim within the @t{<HEAD>}
-;;section.
-(define (html:start-page title . args)
+;;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)))
- (html:printf "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\\n")
- (html:printf "<HTML>\\n")
- (html:comment "HTML by SLIB"
- "http://swissnet.ai.mit.edu/~jaffer/SLIB.html")
- (html:printf "<HEAD>%s<TITLE>%s</TITLE></HEAD>\\n"
- (apply string-append args) (make-plain title))
- (html:printf "<BODY><H1>%s</H1>\\n"
- (or backlink (make-plain title))))
-
-;;@body Outputs HTML codes to end a page.
-(define (html:end-page)
- (html:printf "</BODY>\\n")
- (html:printf "</HTML>\\n"))
-
-;;@body Writes (using @code{html:printf}) 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.
+ (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)
- (html:printf "<PRE>\\n%s" (make-plain line1))
- (for-each (lambda (line) (html:printf "\\n%s" (make-plain line))) lines)
- (html:printf "</PRE>\\n"))
-
-;;@body Writes (using @code{html:printf}) the strings @1 as HTML
-;;comments.
+ (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)
- (html:printf "<!")
- (if (substring? "--" line1)
- (slib:error 'html:comment "line contains --" line1)
- (html:printf "--%s--" line1))
- (for-each (lambda (line)
- (if (substring? "--" line)
- (slib:error 'html:comment "line contains --" line)
- (html:printf "\\n --%s--" line)))
- lines)
- (html:printf ">\\n"))
-
-;;@section HTML Tables
-
-;;@body
-(define (html:start-table caption)
- (html:printf "<TABLE BORDER WIDTH=\"100%%\">\\n")
- (html:printf "<CAPTION ALIGN=BOTTOM>%s</CAPTION>\\n" (make-plain caption)))
-
-;;@body
-(define (html:end-table)
- (html:printf "</TABLE>\\n"))
-
-;;@body Outputs a heading row for the currently-started table.
-(define (html:heading columns)
- (html:printf "<TR VALIGN=\"TOP\">\\n")
- (for-each (lambda (datum) (html:printf "<TH>%s\\n" (or datum ""))) columns))
-
-;;@body Outputs a heading row with column-names @1 linked to URLs @2.
-(define (html:href-heading columns urls)
- (html:heading
- (map (lambda (column url)
- (if url
- (sprintf #f "<A HREF=\"%s\">%s</A>" url column)
- column))
- columns urls)))
-
-;;@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 prints the table row to @var{*html:output-port*}.
-(define (make-row-converter pkl foreigns)
- (lambda (data-row)
- (define anchored? #f)
- (define (present datum)
- (cond ((or (string? datum) (symbol? datum))
- (html:printf "%s" (make-plain datum)))
- (else
- (html:printf
- "<PRE>\\n%s</PRE>\\n"
- (make-plain (call-with-output-string
- (lambda (port)
- (pretty-print datum port))))))))
- (html:printf "<TR VALIGN=\"TOP\">")
- (for-each (lambda (datum foreign)
- (html:printf "<TD>")
- (cond ((not datum))
- ((null? datum))
- ((not anchored?)
- (html:printf "<A NAME=\"")
- (cond
- ((zero? pkl)
- (html:printf "%s" (make-atval datum)))
- (else (html:printf
- "%s" (make-atval (car data-row)))
- (do ((idx 1 (+ 1 idx))
- (contents (cdr data-row) (cdr contents)))
- ((>= idx pkl))
- (html:printf
- " %s" (make-atval (car contents))))))
- (html:printf "\">")
- (set! anchored? (not (zero? pkl)))))
- (cond ((not datum)) ((null? datum))
- ((not foreign) (present datum))
- ((zero? pkl)
- (html:printf "<A HREF=\"%s\">" foreign)
- (present datum)
- (html:printf "</A>"))
- (else
- (html:printf "<A HREF=\"%s#%s\">"
- foreign (make-atval datum))
- (present datum)
- (html:printf "</A>"))))
- data-row foreigns)
- (html:printf "\\n")))
-
-;;@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{}
-;;Writes HTML for @2 table @3 to @var{*html:output-port*}.
-;;
-;;The optional @4 @dots{} arguments restrict actions to a subset of
-;;the table. @xref{Table Operations, match-key}.
-(define (table->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)))
- (html:start-table caption)
- (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))
- (apply (table 'for-each-row) (make-row-converter primlim tags) args)
- (html:end-table)))
-
-;;@body
-;;Writes a complete HTML page to @var{*html:output-port*}. The string
-;;@3 names the page which refers to this one.
-(define (table->page db table-name index-filename)
- (dynamic-wind
- (lambda ()
- (if index-filename
- (html:start-page
- table-name
- (sprintf #f "<A HREF=\"%s#%s\">%s</A>"
- index-filename
- (make-atval table-name)
- (make-plain table-name)))
- (html:start-page table-name)))
- (lambda () (table->html table-name db table-name))
- html:end-page))
-
-;;@body
-;;Writes HTML for the catalog table of @1 to @var{*html:output-port*}.
-(define (catalog->html db caption)
- (html:start-table caption)
- (html:heading '(table columns))
- ((((db 'open-table) '*catalog-data* #f) 'for-each-row)
- (lambda (row)
- (cond ((and (eq? '*columns* (caddr row))
- (not (eq? '*columns* (car row)))))
- (else ((make-row-converter
- 0 (list (table-name->filename (car row))
- (table-name->filename (caddr row))))
- (list (car row) (caddr row))))))))
-
-;;@body
-;;Writes a complete HTML page for the catalog of @1 to
-;;@var{*html:output-port*}.
-(define (catalog->page db caption)
- (dynamic-wind
- (lambda () (html:start-page caption))
- (lambda ()
- (catalog->html db caption)
- (html:end-table))
- html:end-page))
+ (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
-(define (html:dt-strong-doc name doc)
- (if (and (string? doc) (not (equal? "" doc)))
- (html:printf "<DT><STRONG>%s</STRONG> (%s)\\n"
- (make-plain name) (make-plain doc))
- (html:printf "<DT><STRONG>%s</STRONG>\\n" (make-plain name))))
-
-(define (html:checkbox name doc pname)
- (html:printf "<DT><INPUT TYPE=CHECKBOX NAME=%#a VALUE=T>\\n"
- (make-atval pname))
- (if (and (string? doc) (not (equal? "" doc)))
- (html:printf "<DD><STRONG>%s</STRONG> (%s)\\n"
- (make-plain name) (make-plain doc))
- (html:printf "<DD><STRONG>%s</STRONG>\\n" (make-plain name))))
-
-(define (html:text name doc pname default)
+;;@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
- (html:dt-strong-doc name doc)
- (html:printf "<DD><INPUT NAME=%#a SIZE=%d VALUE=%#a>\\n"
- (make-atval pname)
- (max 20 (string-length
- (if (symbol? default)
- (symbol->string default) default)))
- (make-atval default)))
- (else
- (html:dt-strong-doc name doc)
- (html:printf "<DD><INPUT NAME=%#a>\\n" (make-atval pname)))))
-
-(define (html:text-area name doc pname default-list)
- (html:dt-strong-doc name doc)
- (html:printf "<DD><TEXTAREA NAME=%#a ROWS=%d COLS=%d>\\n"
- (make-atval pname) (max 2 (length default-list))
- (apply max 32 (map (lambda (d) (string-length
- (if (symbol? d)
- (symbol->string d)
- d)))
- default-list)))
- (for-each (lambda (line) (html:printf "%s\\n" (make-plain line))) default-list)
- (html:printf "</TEXTAREA>\\n"))
+ (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))
@@ -311,117 +208,174 @@
(string<? (if (symbol? s1) (symbol->string s1) s1)
(if (symbol? s2) (symbol->string s2) s2))))
-(define (html:select name doc pname arity default-list value-list)
- (set! value-list (sort! value-list html:s<?))
- (html:dt-strong-doc name doc)
- (html:printf "<DD><SELECT NAME=%#a SIZE=%d%s>\\n"
- (make-atval pname)
- (case arity
- ((single optional) 1)
- ((nary nary1) 5))
- (case arity
- ((nary nary1) " MULTIPLE")
- (else "")))
- (for-each (lambda (value)
- (html:printf "<OPTION VALUE=%#a%s>%s\\n"
- (make-atval value)
- (if (member value default-list)
- " SELECTED" "")
- (make-plain value)))
- (case arity
- ((optional nary) (cons (string->symbol "") value-list))
- (else value-list)))
- (html:printf "</SELECT>\\n"))
-
-(define (html:buttons name doc pname arity default-list value-list)
- (set! value-list (sort! value-list html:s<?))
- (html:dt-strong-doc name doc)
- (html:printf "<DD><MENU>")
- (case arity
- ((single optional)
- (for-each (lambda (value)
- (html:printf
- "<LI><INPUT TYPE=RADIO NAME=%#a VALUE=%#a%s> %s\\n"
- (make-atval pname) (make-atval value)
- (if (member value default-list) " CHECKED" "")
- (make-plain value)))
- value-list))
- ((nary nary1)
- (for-each (lambda (value)
- (html:printf
- "<LI><INPUT TYPE=CHECKBOX NAME=%#a VALUE=%#a%s> %s\\n"
- (make-atval pname) (make-atval value)
- (if (member value default-list) " CHECKED" "")
- (make-plain value)))
- value-list)))
- (html:printf "</MENU>"))
-
-;;@body The symbol @1 is either @code{get}, @code{head}, @code{post},
-;;@code{put}, or @code{delete}. @0 prints the header for an HTML
-;;@dfn{form}.
-(define (html:start-form method action)
- (cond ((not (memq method '(get head post put delete)))
- (slib:error 'html:start-form "method unknown:" method)))
- (html:printf "<FORM METHOD=%#a ACTION=%#a>\\n"
- (make-atval method) (make-atval action))
- (html:printf "<DL>\\n"))
-
-;;@body @0 prints the footer for an HTML @dfn{form}. The string @2
-;;appears on the button which submits the form.
-(define (html:end-form pname submit-label)
- (html:printf "</DL>\\n")
- (html:printf "<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a> <INPUT TYPE=RESET>\\n"
- (make-atval '*command*) (make-atval submit-label))
- (html:printf "</FORM><HR>\\n"))
+(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))))
-(define (html:generate-form comname method action docu pnames docs aliases
- arities types default-lists value-lists)
- (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))))))
- aliases)
- (dynamic-wind
- (lambda ()
- (html:printf "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n"
- (make-plain comname) (make-plain docu))
- (html:start-form 'post action))
- (lambda ()
- (for-each
- (lambda (pname doc aliat arity default-list value-list)
- (define longname
- (remove-if (lambda (s) (= 1 (string-length s))) (cdr aliat)))
- (set! longname (if (null? longname) #f (car longname)))
- (cond (longname
- (case (length value-list)
- ((0) (case arity
- ((boolean) (html:checkbox longname doc pname 'Y))
- ((single optional)
- (html:text longname doc pname
- (if (null? default-list)
- #f (car default-list))))
- (else
- (html:text-area longname doc pname default-list))))
- ((1) (html:checkbox longname doc pname (car value-list)))
- (else ((case arity
- ((single optional) html:select)
- (else html:buttons))
- longname doc pname arity default-list value-list))))))
- pnames docs aliast arities default-lists value-lists))
- (lambda ()
- (html:end-form comname comname))))
+;;@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.
+;;@body
;;
-;;@0 writes an HTML-2.0 @dfn{form} for command @3 to the
-;;current-output-port. The @samp{SUBMIT} button, which is labeled @3,
-;;invokes the URI @5 with method @4 with a hidden attribute
-;;@code{*command*} bound to the command symbol submitted.
+;;The symbol @2 names a command table in the @1 relational database.
+;;The symbol @3 names a key in @2.
;;
-;;An action may invoke a CGI script
-;;(@samp{http://www.my-site.edu/cgi-bin/search.cgi}) or HTTP daemon
-;;(@samp{http://www.my-site.edu:8001}).
+;;@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.
@@ -430,29 +384,34 @@
;;(require (in-vicinity (implementation-vicinity) "build.scm"))
;;(call-with-output-file "buildscm.html"
;; (lambda (port)
-;; (fluid-let ((*html:output-port* port))
-;; (html:start-page 'commands)
-;; (command->html
-;; build '*commands* 'build 'post
-;; (or "/cgi-bin/build.cgi"
-;; "http://localhost:8081/buildscm"))
-;; html:end-page)))
+;; (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->html rdb command-table command method action)
+(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-domain-choices
- (let ((for-tab-name
- ((rdb-open '*domains-data* #f) 'get 'foreign-table)))
+ ;;(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 (for-tab-name domain-name))
+ (define tab-name (ftn domain-name))
(if tab-name
- (do ((dlst (((rdb-open tab-name #f) 'get* 1)) (cdr dlst))
- (out '() (if (member (car dlst) (cdr dlst))
- out (cons (car dlst) out))))
- ((null? dlst) out))
+ (get-foreign-choices (rdb-open tab-name #f))
'())))))
(define row-ref
(let ((names (comtab 'column-names)))
@@ -463,387 +422,28 @@
(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)))
- (html:generate-form
- command
- method
- action
- (row-ref command:row 'documentation)
- (map (row-refer (position 'name pcnames)) param-rows)
- (map (row-refer (position 'documentation pcnames)) param-rows)
- (map list ((parameter-names 'get* 'name))
- (map (parameter-table 'get 'name)
- ((parameter-names 'get* 'parameter-index))))
- (map (row-refer (position 'arity pcnames)) param-rows)
- (map domain->type domains)
- (map cdr (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))))
- (map get-domain-choices domains))))))
-
-(define (cgi:process-% str)
- (define len (string-length str))
- (define (sub str)
- (cond
- ((strsrch:string-index str #\%)
- => (lambda (idx)
- (if (and (< (+ 2 idx) len)
- (string->number (substring str (+ 1 idx) (+ 2 idx)) 16)
- (string->number (substring str (+ 2 idx) (+ 3 idx)) 16))
- (string-append
- (substring str 0 idx)
- (string (integer->char
- (string->number
- (substring str (+ 1 idx) (+ 3 idx))
- 16)))
- (sub (substring str (+ 3 idx) (string-length str)))))))
- (else str)))
- (sub str))
-
-(define (form:split-lines txt)
- (let ((idx (strsrch:string-index txt #\newline))
- (carriage-return (integer->char #xd)))
- (if idx
- (cons (substring txt 0
- (if (and (positive? idx)
- (char=? carriage-return
- (string-ref txt (+ -1 idx))))
- (+ -1 idx)
- idx))
- (form:split-lines
- (substring txt (+ 1 idx) (string-length txt))))
- (list txt))))
-
-(define (form-urlencoded->query-alist txt)
- (if (symbol? txt) (set! txt (symbol->string txt)))
- (set! txt (string-subst txt " " "" "+" " "))
- (do ((lst '())
- (edx (strsrch:string-index txt #\=)
- (strsrch:string-index txt #\=)))
- ((not edx) lst)
- (let* ((rxt (substring txt (+ 1 edx) (string-length txt)))
- (adx (strsrch:string-index rxt #\&))
- (name (cgi:process-% (substring txt 0 edx))))
- (set!
- lst (append
- lst
- (map
- (lambda (value) (list (string->symbol name)
- (if (equal? "" value) #f value)))
- (form:split-lines
- (cgi:process-% (substring rxt 0 (or adx (string-length rxt))))))))
- (set! txt (if adx (substring rxt (+ 1 adx) (string-length rxt)) "")))))
-
-(define (query-alist->parameter-list alist optnames arities types)
- (define (can-take-arg? opt)
- (not (eq? (list-ref arities (position opt optnames)) 'boolean)))
- (let ((parameter-list (make-parameter-list optnames)))
- (for-each
- (lambda (lst)
- (let* ((value (cadr lst))
- (name (car lst)))
- (cond ((not (can-take-arg? name))
- (adjoin-parameters! parameter-list (list name #t)))
- (value
- (adjoin-parameters!
- parameter-list
- (let ((type (list-ref types (position name optnames))))
- (case type
- ((expression) (list name value))
- ((symbol)
- (if (string? value)
- (call-with-input-string
- value
- (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))
- (cons name lst)))))
- (list name (coerce value type))))
- (else (list name (coerce value type))))))))))
- alist)
- parameter-list))
-
-;;@c node HTTP and CGI service, Printing Scheme, HTML Forms, Textual Conversion Packages
-;;@section HTTP and CGI service
-
-;;@code{(require 'html-form)}
-
-;;;; Now that we have generated the HTML form, process the ensuing CGI request.
-
-;;@body Reads a @samp{"POST"} or @samp{"GET"} query from
-;;@code{(current-input-port)} and executes the encoded command from @2
-;;in relational-database @1.
-;;
-;;This example puts up a plain-text page in response to a CGI query.
-;;
-;;@example
-;;(display "Content-Type: text/plain") (newline) (newline)
-;;(require 'html-form)
-;;(load (in-vicinity (implementation-vicinity) "build.scm"))
-;;(cgi:serve-command build '*commands*)
-;;@end example
-(define (cgi:serve-command rdb command-table)
- (serve-urlencoded-command rdb command-table (cgi:read-query-string)))
-
-;;@body Reads attribute-value pairs from @3, converts them to
-;;parameters and invokes the @1 command named by the parameter
-;;@code{*command*}.
-(define (serve-urlencoded-command rdb command-table urlencoded)
- (let* ((alist (form-urlencoded->query-alist urlencoded))
- (comname #f)
- (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)))
- (set! alist (remove-if (lambda (elt)
- (cond ((not (and (list? elt) (pair? elt)
- (eq? '*command* (car elt)))) #f)
- (comname
- (slib:error
- 'serve-urlencoded-command
- 'more-than-one-command? comname
- (string->symbol (cadr elt))))
- (else (set! comname
- (string-ci->symbol (cadr elt)))
- #t)))
- alist))
- (let* ((command:row (comgetrow comname))
- (parameter-table ((rdb 'open-table)
- (row-ref command:row 'parameters) #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)))
-
- (let* ((params (query-alist->parameter-list alist options arities types))
- (fparams (fill-empty-parameters defaulters params)))
- (and (list? fparams) (check-parameters dirs fparams)
- (comval fparams))))))
-
-(define (serve-query-alist-command rdb command-table alist)
- (let ((command #f))
- (set! alist (remove-if (lambda (elt)
- (cond ((not (and (list? elt) (pair? elt)
- (eq? '*command* (car elt)))) #f)
- (command
- (slib:error
- 'serve-query-alist-command
- 'more-than-one-command? command
- (string->symbol (cadr elt))))
- (else (set! command
- (string-ci->symbol (cadr elt)))
- #t)))
- alist))
- ((make-command-server rdb command-table)
- command
- (lambda (comname comval options positions
- arities types defaulters dirs aliases)
- (let* ((params (query-alist->parameter-list alist options arities types))
- (fparams (fill-empty-parameters defaulters params)))
- (and (list? fparams) (check-parameters dirs fparams)
- (apply comval
- (parameter-list->arglist positions arities fparams))))))))
-
-(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 (strsrch: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)
- (strsrch:string-index request-uri #\?)
- (substring request-uri
- (+ 1 (strsrch: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:send-status-line status-code reason)
- (html:printf "HTTP/1.1 %d %s%s" status-code reason http:crlf))
-(define (http:send-header alist)
- (for-each (lambda (pair)
- (html:printf "%s: %s%s" (car pair) (cdr pair) http:crlf))
- alist)
- (html:printf http:crlf))
-
-(define *http:byline*
- "<A HREF=http://swissnet.ai.mit.edu/~jaffer/SLIB.html>SLIB </A>HTTP/1.1 server")
-
-(define (http:send-error-page code str port)
- (fluid-let ((*html:output-port* port))
- (http:send-status-line code str)
- (http:send-header '(("Content-Type" . "text/html")))
- (html:start-page (sprintf #f "%d %s" code str))
- (and *http:byline* (html:printf "<HR>\\n%s\\n" *http:byline*))
- (html:end-page)))
-
-;;@body reads the @dfn{query-string} from @1. If this is a valid
-;;@samp{"POST"} or @samp{"GET"} query, then @0 calls @3 with two
-;;arguments, the query-string and the header-alist.
-;;
-;;Otherwise, @0 replies (to @2) with appropriate HTML describing the
-;;problem.
-(define (http:serve-query input-port output-port serve-proc)
- (let ((request-line (http:read-request-line input-port)))
- (cond ((not request-line)
- (http:send-error-page 400 "Bad Request" output-port))
- ((string? (car request-line))
- (http:send-error-page 501 "Not Implemented" output-port))
- ((not (case (car request-line)
- ((get post) #t)
- (else #f)))
- (http:send-error-page 405 "Method Not Allowed" output-port))
- (else (let* ((header (http:read-header input-port))
- (query-string
- (http:read-query-string
- request-line header input-port)))
- (cond ((not query-string)
- (http:send-error-page 400 "Bad Request" output-port))
- (else (http:send-status-line 200 "OK")
- (serve-proc query-string header))))))))
-
-;;@ This example services HTTP queries from port 8081:
-;;
-;;@example
-;;(define socket (make-stream-socket AF_INET 0))
-;;(socket:bind socket 8081)
-;;(socket:listen socket 10)
-;;(dynamic-wind
-;; (lambda () #f)
-;; (lambda ()
-;; (do ((port (socket:accept socket)
-;; (socket:accept socket)))
-;; (#f)
-;; (dynamic-wind
-;; (lambda () #f)
-;; (lambda ()
-;; (fluid-let ((*html:output-port* port))
-;; (http:serve-query
-;; port port
-;; (lambda (query-string header)
-;; (http:send-header
-;; '(("Content-Type" . "text/plain")))
-;; (with-output-to-port port
-;; (lambda ()
-;; (serve-urlencoded-command
-;; build '*commands* query-string)))))))
-;; (lambda () (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 Reads the first non-blank line from @1 and, if successful,
-;;returns a list of three itmes from the request-line:
-;;
-;;@enumerate 0
-;;
-;;@item Method
-;;
-;;Either one of the symbols @code{options}, @code{get}, @code{head},
-;;@code{post}, @code{put}, @code{delete}, or @code{trace}; Or a string.
-;;
-;;@item Request-URI
-;;
-;;A string. 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))
- (let ((method
- (assoc
- (car lst)
- '(("OPTIONS" . options) ; Section 9.2
- ("GET" . get) ; Section 9.3
- ("HEAD" . head) ; Section 9.4
- ("POST" . post) ; Section 9.5
- ("PUT" . put) ; Section 9.6
- ("DELETE" . delete) ; Section 9.7
- ("TRACE" . trace) ; Section 9.8
- ))))
- (cons (if (pair? method) (cdr method) (car lst)) (cdr lst))))))
-
-;;@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)))
+ (parameter-names (rdb-open (row-ref command:row 'parameter-names) #f))
+ (pnames (map (row-refer (position 'name pcnames)) param-rows)))
+ (define foreign-values (map get-foreign-values domains))
+ (define aliast (map list pnames))
+ (for-each (lambda (alias)
+ (if (> (string-length (car alias)) 1)
+ (let ((apr (assq (cadr alias) aliast)))
+ (set-cdr! apr (cons (car alias) (cdr apr))))))
+ (map list
+ ((parameter-names 'get* 'name))
+ (map (parameter-table 'get 'name)
+ ((parameter-names 'get* 'parameter-index)))))
+ (list pnames
+ (map (row-refer (position 'documentation pcnames)) param-rows)
+ aliast
+ (map (row-refer (position 'arity pcnames)) param-rows)
+ ;;(map domain->type domains)
+ (map cdr ;(lambda (lst) (if (null? lst) lst (cdr lst)))
+ (fill-empty-parameters
+ (map slib:eval
+ (map (row-refer (position 'defaulter pcnames))
+ param-rows))
+ (make-parameter-list
+ (map (row-refer (position 'name pcnames)) param-rows))))
+ foreign-values)))))
diff --git a/htmlform.txi b/htmlform.txi
index c16818f..ffa0665 100644
--- a/htmlform.txi
+++ b/htmlform.txi
@@ -1,162 +1,182 @@
-
-
-
@code{(require 'html-form)}
+@ftindex html-form
-@defvar *html:output-port*
-Procedure names starting with @samp{html:} send their output
-to the port @var{*html:output-port*}. @var{*html:output-port*} is initially the current output port.
-@end defvar
-
-
-@defun make-atval txt
+@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 make-plain txt
+@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:start-page title backlink @dots{}
-Outputs headers for an HTML page named @var{title}.
+@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:end-page
-Outputs HTML codes to end a page.
+@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
-@defun html:pre line1 line @dots{}
-Writes (using @code{html:printf}) the strings @var{line1}, @var{lines} as
-@dfn{PRE}formmated plain text (rendered in fixed-width font).
-@cindex PRE
-Newlines are inserted between @var{line1}, @var{lines}. HTML tags (@samp{<tag>})
-within @var{lines} will be visible verbatim.
-@end defun
+@defunx html:meta-refresh delay
-@defun html:comment line1 line @dots{}
-Writes (using @code{html:printf}) the strings @var{line1} as HTML
-comments.
+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{}
-@section HTML Tables
-@defun html:start-table caption
+@defunx html:head title backlink
-@end defun
-
-
-@defun html:end-table
+@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:heading columns
-Outputs a heading row for the currently-started table.
+@defun html:body body @dots{}
+Returns HTML string to end a page.
@end defun
-
-@defun html:href-heading columns urls
-Outputs a heading row with column-names @var{columns} linked to URLs @var{urls}.
+@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 make-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{make-row-converter} returns a procedure taking a row for its single argument. This
-returned procedure prints the table row to @var{*html:output-port*}.
+@defun html:comment line1 line @dots{}
+Returns the strings @var{line1} as HTML comments.
@end defun
+@section HTML Forms
-@defun table-name->filename table-name
-
-Returns the symbol @var{table-name} converted to a filename.
+@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 table->html caption db table-name match-key1 @dots{}
-
-Writes HTML for @var{db} table @var{table-name} to @var{*html:output-port*}.
-
-The optional @var{match-key1} @dots{} arguments restrict actions to a subset of
-the table. @xref{Table Operations, match-key}.
+@defun html:hidden name value
+Returns HTML string which will cause @var{name}=@var{value} in form.
@end defun
-
-@defun table->page db table-name index-filename
-
-Writes a complete HTML page to @var{*html:output-port*}. The string
-@var{index-filename} names the page which refers to this one.
+@defun html:checkbox pname default
+Returns HTML string for check box.
@end defun
-
-@defun catalog->html db caption
-
-Writes HTML for the catalog table of @var{db} to @var{*html:output-port*}.
+@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 catalog->page db caption
+@defun html:select pname arity default-list foreign-values
+Returns HTML string for pull-down menu selector.
+@end defun
-Writes a complete HTML page for the catalog of @var{db} to
-@var{*html:output-port*}.
+@defun html:buttons pname arity default-list foreign-values
+Returns HTML string for any-of selector.
@end defun
+@defun form:submit submit-label command
-@section HTML Forms
+@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:
-@defun html:start-form method action
-The symbol @var{method} is either @code{get}, @code{head}, @code{post},
-@code{put}, or @code{delete}. @code{html:start-form} prints the header for an HTML
-@dfn{form}.
-@cindex form
+@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
-@defun html:end-form pname submit-label
-@code{html:end-form} prints the footer for an HTML @dfn{form}. The string @var{submit-label}
-@cindex form
-appears on the button which submits the form.
+
+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
-@defun command->html rdb command-table command method action
-The symbol @var{command-table} names a command table in the @var{rdb} relational
-database.
+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->html} writes an HTML-2.0 @dfn{form} for command @var{command} to the
-@cindex form
-current-output-port. The @samp{SUBMIT} button, which is labeled @var{command},
-invokes the URI @var{action} with method @var{method} with a hidden attribute
-@code{*command*} bound to the command symbol submitted.
-
-An action may invoke a CGI script
-(@samp{http://www.my-site.edu/cgi-bin/search.cgi}) or HTTP daemon
-(@samp{http://www.my-site.edu:8001}).
+@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.
@@ -165,122 +185,21 @@ command.
(require (in-vicinity (implementation-vicinity) "build.scm"))
(call-with-output-file "buildscm.html"
(lambda (port)
- (fluid-let ((*html:output-port* port))
- (html:start-page 'commands)
- (command->html
- build '*commands* 'build 'post
- (or "/cgi-bin/build.cgi"
- "http://localhost:8081/buildscm"))
- html:end-page)))
-@end example
-@end defun
-
-
-
-
-
-
-@c node HTTP and CGI service, Printing Scheme, HTML Forms, Textual Conversion Packages
-@section HTTP and CGI service
-
-@code{(require 'html-form)}
-
-
-@defun cgi:serve-command rdb command-table
-Reads a @samp{"POST"} or @samp{"GET"} query from
-@code{(current-input-port)} and executes the encoded command from @var{command-table}
-in relational-database @var{rdb}.
-
-This example puts up a plain-text page in response to a CGI query.
-
-@example
-(display "Content-Type: text/plain") (newline) (newline)
-(require 'html-form)
-(load (in-vicinity (implementation-vicinity) "build.scm"))
-(cgi:serve-command build '*commands*)
+ (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
-
-
-@defun serve-urlencoded-command rdb command-table urlencoded
-Reads attribute-value pairs from @var{urlencoded}, converts them to
-parameters and invokes the @var{rdb} command named by the parameter
-@code{*command*}.
-@end defun
-
-
-
-
-
-
-
-
-@defun http:serve-query input-port output-port serve-proc
-reads the @dfn{query-string} from @var{input-port}. If this is a valid
-@cindex query-string
-@samp{"POST"} or @samp{"GET"} query, then @code{http:serve-query} calls @var{serve-proc} with two
-arguments, the query-string and the header-alist.
-
-Otherwise, @code{http:serve-query} replies (to @var{output-port}) with appropriate HTML describing the
-problem.
-@end defun
-
-
-This example services HTTP queries from port 8081:
-
-@example
-(define socket (make-stream-socket AF_INET 0))
-(socket:bind socket 8081)
-(socket:listen socket 10)
-(dynamic-wind
- (lambda () #f)
- (lambda ()
- (do ((port (socket:accept socket)
- (socket:accept socket)))
- (#f)
- (dynamic-wind
- (lambda () #f)
- (lambda ()
- (fluid-let ((*html:output-port* port))
- (http:serve-query
- port port
- (lambda (query-string header)
- (http:send-header
- '(("Content-Type" . "text/plain")))
- (with-output-to-port port
- (lambda ()
- (serve-urlencoded-command
- build '*commands* query-string)))))))
- (lambda () (close-port port)))))
- (lambda () (close-port socket)))
-@end example
-
-
-@defun http:read-request-line port
-Reads the first non-blank line from @var{port} and, if successful,
-returns a list of three itmes from the request-line:
-
-@enumerate 0
-
-@item Method
-
-Either one of the symbols @code{options}, @code{get}, @code{head},
-@code{post}, @code{put}, @code{delete}, or @code{trace}; Or a string.
-
-@item Request-URI
-
-A string. At the minimum, it will be the string @samp{"/"}.
-
-@item HTTP-Version
-
-A string. For example, @samp{HTTP/1.0}.
-@end enumerate
-@end defun
-
-
-@defun cgi:read-query-string
-Reads the @dfn{query-string} from @code{(current-input-port)}.
-@cindex query-string
-@code{cgi:read-query-string} reads a @samp{"POST"} or @samp{"GET"} queries, depending on the
-value of @code{(getenv "REQUEST_METHOD")}.
-@end defun
diff --git a/http-cgi.scm b/http-cgi.scm
new file mode 100644
index 0000000..a313758
--- /dev/null
+++ b/http-cgi.scm
@@ -0,0 +1,440 @@
+;;; "http-cgi.scm" service HTTP or CGI requests. -*-scheme-*-
+; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of 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)}
+;;@ftindex http
+;;@ftindex 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 (strsrch: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)
+ (strsrch:string-index request-uri #\?)
+ (substring request-uri
+ (+ 1 (strsrch:string-index request-uri #\?))
+ (if (eqv? #\/ (string-ref request-uri (+ -1 len)))
+ (+ -1 len)
+ len)))))
+ ((post put delete)
+ (let ((content-length (assq 'content-length header)))
+ (and content-length
+ (set! content-length (string->number (cdr content-length))))
+ (and content-length
+ (let ((str (make-string content-length #\ )))
+ (do ((idx 0 (+ idx 1)))
+ ((>= idx content-length)
+ (if (>= idx (string-length str)) str (substring str 0 idx)))
+ (let ((chr (read-char port)))
+ (if (char? chr)
+ (string-set! str idx chr)
+ (set! content-length idx))))))))
+ (else #f)))
+
+(define (http:status-line status-code reason)
+ (sprintf #f "HTTP/1.1 %d %s%s" status-code reason http:crlf))
+
+;;@body Returns a string containing lines for each element of @1; the
+;;@code{car} of which is followed by @samp{: }, then the @code{cdr}.
+(define (http:header alist)
+ (string-append
+ (apply string-append
+ (map (lambda (pair)
+ (sprintf #f "%s: %s%s" (car pair) (cdr pair) http:crlf))
+ alist))
+ http:crlf))
+
+;;@body Returns the concatenation of strings @2 with the
+;;@code{(http:header @1)} and the @samp{Content-Length} prepended.
+(define (http:content alist . body)
+ (define hunk (apply string-append body))
+ (string-append (http:header
+ (cons (cons "Content-Length"
+ (number->string (string-length hunk)))
+ alist))
+ hunk))
+
+;;@body String appearing at the bottom of error pages.
+(define *http:byline* #f)
+
+;;@body @1 and @2 should be an integer and string as specified in
+;;@cite{RFC 2068}. The returned page (string) will show the @1 and @2
+;;and any additional @3 @dots{}; with @var{*http:byline*} or SLIB's
+;;default at the bottom.
+(define (http:error-page status-code reason-phrase . html-strings)
+ (define byline
+ (or
+ *http:byline*
+ (sprintf
+ #f
+ "<A HREF=http://swissnet.ai.mit.edu/~jaffer/SLIB.html>SLIB</A> %s server"
+ (if (getenv "SERVER_PROTOCOL") "CGI/1.1" "HTTP/1.1"))))
+ (string-append (http:status-line status-code reason-phrase)
+ (http:content
+ '(("Content-Type" . "text/html"))
+ (html:head (sprintf #f "%d %s" status-code reason-phrase))
+ (apply html:body
+ (append html-strings
+ (list (sprintf #f "<HR>\\n%s\\n" byline)))))))
+
+;;@body The string or symbol @1 is the page title. @2 is a non-negative
+;;integer. The @4 @dots{} are typically used to explain to the user why
+;;this page is being forwarded.
+;;
+;;@0 returns an HTML string for a page which automatically forwards to
+;;@3 after @2 seconds. The returned page (string) contains any @4
+;;@dots{} followed by a manual link to @3, in case the browser does not
+;;forward automatically.
+(define (http:forwarding-page title delay uri . html-strings)
+ (string-append
+ (html:head title #f (html:meta-refresh delay uri))
+ (apply html:body
+ (append html-strings
+ (list (sprintf #f "\\n\\n<HR>\\nReturn to %s.\\n"
+ (html:link uri title)))))))
+
+;;@body reads the @dfn{URI} and @dfn{query-string} from @2. If the
+;;query is a valid @samp{"POST"} or @samp{"GET"} query, then @0 calls
+;;@1 with three arguments, the @var{request-line}, @var{query-string},
+;;and @var{header-alist}. Otherwise, @0 calls @1 with the
+;;@var{request-line}, #f, and @var{header-alist}.
+;;
+;;If @1 returns a string, it is sent to @3. If @1 returns a list,
+;;then an error page with number 525 and strings from the list. If @1
+;;returns #f, then a @samp{Bad Request} (400) page is sent to @3.
+;;
+;;Otherwise, @0 replies (to @3) with appropriate HTML describing the
+;;problem.
+(define (http:serve-query serve-proc input-port output-port)
+ (let* ((request-line (http:read-request-line input-port))
+ (header (and request-line (http:read-header input-port)))
+ (query-string (and header (http:read-query-string
+ request-line header input-port))))
+ (display (http:service serve-proc request-line query-string header)
+ output-port)))
+
+(define (http:service serve-proc request-line query-string header)
+ (cond ((not request-line) (http:error-page 400 "Bad Request."))
+ ((string? (car request-line))
+ (http:error-page 501 "Not Implemented" (html:plain request-line)))
+ ((not (memq (car request-line) '(get post)))
+ (http:error-page 405 "Method Not Allowed" (html:plain request-line)))
+ ((serve-proc request-line query-string header) =>
+ (lambda (reply)
+ (cond ((string? reply)
+ (string-append (http:status-line 200 "OK")
+ reply))
+ ((and (pair? reply) (list? reply))
+ (if (number? (car reply))
+ (apply http:error-page reply)
+ (apply http:error-page 525 reply)))
+ (else (http:error-page 500 "Internal Server Error")))))
+ ((not query-string)
+ (http:error-page 400 "Bad Request" (html:plain request-line)))
+ (else
+ (http:error-page 500 "Internal Server Error" (html:plain header)))))
+
+;;@
+;;
+;;This example services HTTP queries from @var{port-number}:
+;;@example
+;;
+;;(define socket (make-stream-socket AF_INET 0))
+;;(and (socket:bind socket port-number) ; AF_INET INADDR_ANY
+;; (socket:listen socket 10) ; Queue up to 10 requests.
+;; (dynamic-wind
+;; (lambda () #f)
+;; (lambda ()
+;; (do ((port (socket:accept socket) (socket:accept socket)))
+;; (#f)
+;; (let ((iport (duplicate-port port "r"))
+;; (oport (duplicate-port port "w")))
+;; (http:serve-query build:serve iport oport)
+;; (close-port iport)
+;; (close-port oport))
+;; (close-port port)))
+;; (lambda () (close-port socket))))
+;;@end example
+
+(define (http:read-start-line port)
+ (do ((line (read-line port) (read-line port)))
+ ((or (not (equal? "" line)) (eof-object? line)) line)))
+
+;; @body
+;; Request lines are a list of three itmes:
+;;
+;; @enumerate 0
+;;
+;; @item Method
+;;
+;; A symbol (@code{options}, @code{get}, @code{head}, @code{post},
+;; @code{put}, @code{delete}, @code{trace} @dots{}).
+;;
+;; @item Request-URI
+;;
+;; A string. For direct HTTP, at the minimum it will be the string
+;; @samp{"/"}.
+;;
+;; @item HTTP-Version
+;;
+;; A string. For example, @samp{HTTP/1.0}.
+;; @end enumerate
+(define (http:read-request-line port)
+ (let ((lst (scanf-read-list "%s %s %s %s" (http:read-start-line port))))
+ (and (list? lst)
+ (= 3 (length lst))
+ (cons (string-ci->symbol (car lst)) (cdr lst)))))
+(define (cgi:request-line)
+ (define method (getenv "REQUEST_METHOD"))
+ (and method
+ (list (string-ci->symbol method)
+ (getenv "SCRIPT_NAME")
+ (getenv "SERVER_PROTOCOL"))))
+
+(define (cgi:query-header)
+ (define assqs '())
+ (cond ((and (getenv "SERVER_NAME") (getenv "SERVER_PORT"))
+ (set! assqs (cons (cons 'host (string-append (getenv "SERVER_NAME")
+ ":"
+ (getenv "SERVER_PORT")))
+ assqs))))
+ (for-each
+ (lambda (envar)
+ (define valstr (getenv envar))
+ (if valstr (set! assqs
+ (cons (cons (string-ci->symbol
+ (string-subst envar "HTTP_" "" "_" "-"))
+ valstr)
+ assqs))))
+ '(
+ ;;"AUTH_TYPE"
+ "CONTENT_LENGTH"
+ "CONTENT_TYPE"
+ "DOCUMENT_ROOT"
+ "GATEWAY_INTERFACE"
+ "HTTP_ACCEPT"
+ "HTTP_ACCEPT_CHARSET"
+ "HTTP_ACCEPT_ENCODING"
+ "HTTP_ACCEPT_LANGUAGE"
+ "HTTP_CONNECTION"
+ "HTTP_HOST"
+ ;;"HTTP_PRAGMA"
+ "HTTP_REFERER"
+ "HTTP_USER_AGENT"
+ "PATH_INFO"
+ "PATH_TRANSLATED"
+ "QUERY_STRING"
+ "REMOTE_ADDR"
+ "REMOTE_HOST"
+ ;;"REMOTE_IDENT"
+ ;;"REMOTE_USER"
+ "REQUEST_URI"
+ "SCRIPT_FILENAME"
+ "SCRIPT_NAME"
+ ;;"SERVER_SIGNATURE"
+ ;;"SERVER_SOFTWARE"
+ ))
+ assqs)
+
+;; @body Reads the @dfn{query-string} from @code{(current-input-port)}.
+;; @0 reads a @samp{"POST"} or @samp{"GET"} queries, depending on the
+;; value of @code{(getenv "REQUEST_METHOD")}.
+(define (cgi:read-query-string)
+ (define request-method (getenv "REQUEST_METHOD"))
+ (cond ((and request-method (string-ci=? "GET" request-method))
+ (getenv "QUERY_STRING"))
+ ((and request-method (string-ci=? "POST" request-method))
+ (let ((content-length (getenv "CONTENT_LENGTH")))
+ (and content-length
+ (set! content-length (string->number content-length)))
+ (and content-length
+ (let ((str (make-string content-length #\ )))
+ (do ((idx 0 (+ idx 1)))
+ ((>= idx content-length)
+ (if (>= idx (string-length str))
+ str
+ (substring str 0 idx)))
+ (let ((chr (read-char)))
+ (if (char? chr)
+ (string-set! str idx chr)
+ (set! content-length idx))))))))
+ (else #f)))
+
+;;@body reads the @dfn{URI} and @dfn{query-string} from
+;;@code{(current-input-port)}. If the query is a valid @samp{"POST"}
+;;or @samp{"GET"} query, then @0 calls @1 with three arguments, the
+;;@var{request-line}, @var{query-string}, and @var{header-alist}.
+;;Otherwise, @0 calls @1 with the @var{request-line}, #f, and
+;;@var{header-alist}.
+;;
+;;If @1 returns a string, it is sent to @code{(current-input-port)}.
+;;If @1 returns a list, then an error page with number 525 and strings
+;;from the list. If @1 returns #f, then a @samp{Bad Request} (400)
+;;page is sent to @code{(current-input-port)}.
+;;
+;;Otherwise, @0 replies (to @code{(current-input-port)}) with
+;;appropriate HTML describing the problem.
+(define (cgi:serve-query serve-proc)
+ (let* ((script-name (getenv "SCRIPT_NAME"))
+ (request-line (cgi:request-line))
+ (header (and request-line (cgi:query-header)))
+ (query-string (and header (cgi:read-query-string)))
+ (reply (http:service serve-proc request-line query-string header)))
+ (display (if (and script-name
+ (not (eqv? 0 (substring? "nph-" script-name))))
+ ;; Eat http status line.
+ (substring reply (+ 2 (substring? http:crlf reply))
+ (string-length reply))
+ reply))))
+
+(define (coerce->list str type)
+ (case type
+ ((expression)
+ (slib:warn 'coerce->list 'unsafe 'read)
+ (do ((tok (read port) (read port))
+ (lst '() (cons tok lst)))
+ ((or (null? tok) (eof-object? tok)) lst)))
+ ((symbol)
+ (call-with-input-string str
+ (lambda (port)
+ (do ((tok (scanf-read-list " %s" port)
+ (scanf-read-list " %s" port))
+ (lst '() (cons (string-ci->symbol (car tok)) lst)))
+ ((or (null? tok) (eof-object? tok)) lst)))))
+ (else
+ (call-with-input-string str
+ (lambda (port)
+ (do ((tok (scanf-read-list " %s" port)
+ (scanf-read-list " %s" port))
+ (lst '() (cons (coerce (car tok) type) lst)))
+ ((or (null? tok) (eof-object? tok)) lst)))))))
+
+(define (query-alist->parameter-list alist optnames arities types)
+ (let ((parameter-list (make-parameter-list optnames)))
+ (for-each
+ (lambda (lst)
+ (let* ((value (cadr lst))
+ (name (car lst))
+ (opt-pos (position name optnames)))
+ (cond ((not opt-pos)
+ (slib:warn 'query-alist->parameter-list
+ 'unknown 'parameter name))
+ ((eq? (list-ref arities opt-pos) 'boolean)
+ (adjoin-parameters! parameter-list (list name #t)))
+ ((and (equal? value "")
+ (not (memq (list-ref types opt-pos) '(expression string))))
+ (adjoin-parameters! parameter-list (list name #f)))
+ (value
+ (adjoin-parameters!
+ parameter-list
+ (cons name
+ (case (list-ref arities opt-pos)
+ ((nary nary1)
+ (coerce->list value (list-ref types opt-pos)))
+ (else
+ (list (coerce value (list-ref types opt-pos)))))))))))
+ alist)
+ parameter-list))
+
+;;@args rdb command-table
+;;@args rdb command-table #t
+;;
+;;Returns a procedure of one argument. When that procedure is called
+;;with a @var{query-alist} (as returned by @code{uri:decode-query}, the
+;;value of the @samp{*command*} association will be the command invoked
+;;in @2. If @samp{*command*} is not in the @var{query-alist} then the
+;;value of @samp{*suggest*} is tried. If neither name is in the
+;;@var{query-alist}, then the literal value @samp{*default*} is tried in
+;;@2.
+;;
+;;If optional third argument is non-false, then the command is called
+;;with just the parameter-list; otherwise, command is called with the
+;;arguments described in its table.
+(define (make-query-alist-command-server rdb command-table . just-params?)
+ (define comsrvcal (make-command-server rdb command-table))
+ (set! just-params? (if (null? just-params?) #f (car just-params?)))
+ (lambda (query-alist)
+ (define comnam #f)
+ (define find-command?
+ (lambda (cname)
+ (define tryp (parameter-list-ref query-alist cname))
+ (cond ((not tryp) #f)
+ (comnam
+ (set! query-alist (remove-parameter cname query-alist)))
+ (else
+ (set! query-alist (remove-parameter cname query-alist))
+ (set! comnam (string-ci->symbol (car tryp)))))))
+ (find-command? '*command*)
+ (find-command? '*suggest*)
+ (find-command? '*button*)
+ (cond ((not comnam) (set! comnam '*default*)))
+ (cond
+ (comnam
+ (comsrvcal comnam
+ (lambda (comname comval options positions
+ arities types defaulters dirs aliases)
+ (let* ((params (query-alist->parameter-list
+ query-alist options arities types))
+ (fparams (fill-empty-parameters defaulters params)))
+ (and (list? fparams)
+ (check-parameters dirs fparams)
+ (if just-params?
+ (comval fparams)
+ (let ((arglist (parameter-list->arglist
+ positions arities fparams)))
+ (and arglist
+ (apply comval arglist))))))))))))
diff --git a/http-cgi.txi b/http-cgi.txi
new file mode 100644
index 0000000..67be216
--- /dev/null
+++ b/http-cgi.txi
@@ -0,0 +1,112 @@
+@code{(require 'http)} or @code{(require 'cgi)}
+@ftindex http
+@ftindex cgi
+
+
+@defun http:header alist
+Returns a string containing lines for each element of @var{alist}; the
+@code{car} of which is followed by @samp{: }, then the @code{cdr}.
+@end defun
+
+@defun http:content alist body @dots{}
+Returns the concatenation of strings @var{body} with the
+@code{(http:header @var{alist})} and the @samp{Content-Length} prepended.
+@end defun
+
+@defvar *http:byline*
+String appearing at the bottom of error pages.
+@end defvar
+
+@defun http:error-page status-code reason-phrase html-string @dots{}
+@var{status-code} and @var{reason-phrase} should be an integer and string as specified in
+@cite{RFC 2068}. The returned page (string) will show the @var{status-code} and @var{reason-phrase}
+and any additional @var{html-strings} @dots{}; with @var{*http:byline*} or SLIB's
+default at the bottom.
+@end defun
+
+@defun http:forwarding-page title delay uri html-string @dots{}
+The string or symbol @var{title} is the page title. @var{delay} is a non-negative
+integer. The @var{html-strings} @dots{} are typically used to explain to the user why
+this page is being forwarded.
+
+@code{http:forwarding-page} returns an HTML string for a page which automatically forwards to
+@var{uri} after @var{delay} seconds. The returned page (string) contains any @var{html-strings}
+@dots{} followed by a manual link to @var{uri}, in case the browser does not
+forward automatically.
+@end defun
+
+@defun http:serve-query serve-proc input-port output-port
+reads the @dfn{URI} and @dfn{query-string} from @var{input-port}. If the
+@cindex URI
+@cindex query-string
+query is a valid @samp{"POST"} or @samp{"GET"} query, then @code{http:serve-query} calls
+@var{serve-proc} with three arguments, the @var{request-line}, @var{query-string},
+and @var{header-alist}. Otherwise, @code{http:serve-query} calls @var{serve-proc} with the
+@var{request-line}, #f, and @var{header-alist}.
+
+If @var{serve-proc} returns a string, it is sent to @var{output-port}. If @var{serve-proc} returns a list,
+then an error page with number 525 and strings from the list. If @var{serve-proc}
+returns #f, then a @samp{Bad Request} (400) page is sent to @var{output-port}.
+
+Otherwise, @code{http:serve-query} replies (to @var{output-port}) with appropriate HTML describing the
+problem.
+@end defun
+
+
+This example services HTTP queries from @var{port-number}:
+@example
+
+(define socket (make-stream-socket AF_INET 0))
+(and (socket:bind socket port-number) ; AF_INET INADDR_ANY
+ (socket:listen socket 10) ; Queue up to 10 requests.
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (do ((port (socket:accept socket) (socket:accept socket)))
+ (#f)
+ (let ((iport (duplicate-port port "r"))
+ (oport (duplicate-port port "w")))
+ (http:serve-query build:serve iport oport)
+ (close-port iport)
+ (close-port oport))
+ (close-port port)))
+ (lambda () (close-port socket))))
+@end example
+
+
+@defun cgi:serve-query serve-proc
+reads the @dfn{URI} and @dfn{query-string} from
+@cindex URI
+@cindex query-string
+@code{(current-input-port)}. If the query is a valid @samp{"POST"}
+or @samp{"GET"} query, then @code{cgi:serve-query} calls @var{serve-proc} with three arguments, the
+@var{request-line}, @var{query-string}, and @var{header-alist}.
+Otherwise, @code{cgi:serve-query} calls @var{serve-proc} with the @var{request-line}, #f, and
+@var{header-alist}.
+
+If @var{serve-proc} returns a string, it is sent to @code{(current-input-port)}.
+If @var{serve-proc} returns a list, then an error page with number 525 and strings
+from the list. If @var{serve-proc} returns #f, then a @samp{Bad Request} (400)
+page is sent to @code{(current-input-port)}.
+
+Otherwise, @code{cgi:serve-query} replies (to @code{(current-input-port)}) with
+appropriate HTML describing the problem.
+@end defun
+
+@defun make-query-alist-command-server rdb command-table
+
+
+@defunx make-query-alist-command-server rdb command-table #t
+
+Returns a procedure of one argument. When that procedure is called
+with a @var{query-alist} (as returned by @code{uri:decode-query}, the
+value of the @samp{*command*} association will be the command invoked
+in @var{command-table}. If @samp{*command*} is not in the @var{query-alist} then the
+value of @samp{*suggest*} is tried. If neither name is in the
+@var{query-alist}, then the literal value @samp{*default*} is tried in
+@var{command-table}.
+
+If optional third argument is non-false, then the command is called
+with just the parameter-list; otherwise, command is called with the
+arguments described in its table.
+@end defun
diff --git a/lineio.scm b/lineio.scm
index c80ece8..38a7b87 100644
--- a/lineio.scm
+++ b/lineio.scm
@@ -1,9 +1,9 @@
; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -61,7 +61,7 @@
;;@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 omited, in
+;;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)
diff --git a/lineio.txi b/lineio.txi
index c067678..34d42d5 100644
--- a/lineio.txi
+++ b/lineio.txi
@@ -1,10 +1,8 @@
+@defun read-line
-@defun read-line read-line
-
-
-@defunx read-line read-line port
+@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
@@ -13,12 +11,11 @@ omitted, in which case it defaults to the value returned by
@code{current-input-port}.
@end defun
-
-@defun read-line! read-line! string
+@defun read-line! string
-@defunx read-line! read-line! string port
-Fills @var{read-line!} with characters up to, but not including a newline or end
+@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
@@ -28,19 +25,16 @@ omitted, in which case it defaults to the value returned by
@code{current-input-port}.
@end defun
+@defun write-line string
-@defun write-line write-line string
-
-
-@defunx write-line write-line string port
-Writes @var{write-line} followed by a newline to the given @var{port} and returns
-an unspecified value. The @var{Port} argument may be omited, in
+@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
diff --git a/logical.scm b/logical.scm
index c85507d..963202f 100644
--- a/logical.scm
+++ b/logical.scm
@@ -1,9 +1,9 @@
;;;; "logical.scm", bit access and operations for integers for Scheme
-;;; Copyright (C) 1991, 1993 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/macscheme.init b/macscheme.init
index 16c53bb..72d9259 100644
--- a/macscheme.init
+++ b/macscheme.init
@@ -15,8 +15,8 @@
(define (scheme-implementation-type) 'MacScheme)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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)
@@ -50,58 +50,71 @@
'(
source ;can load scheme source files
;(slib:load-source "filename")
-; compiled ;can load compiled files
+ 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.
+
+ ;; Scheme report features
+
+; rev5-report ;conforms to
+; eval ;R5RS two-argument eval
+; values ;R5RS multiple values
+; dynamic-wind ;R5RS dynamic-wind
+; macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+; char-ready?
+ rationalize
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
+
+ rev4-report ;conforms to
+
+ ieee-p1178 ;conforms to
+
+ rev3-report ;conforms to
+
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
+; object-hash ;has OBJECT-HASH
+
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
+ ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
full-continuation ;can return multiple times
-; object-hash ;has OBJECT-HASH
+ ;; Other common features
+
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+; defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+ string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
; sort
-; queue ;queues
pretty-print
; object->string
-; format
+; format ;Common-lisp output formatting
; 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
+
+ ;; Implementation Specific features
+
))
;;; (OUTPUT-PORT-WIDTH <port>)
@@ -145,6 +158,13 @@
(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)
@@ -213,13 +233,15 @@
(define slib:warn
(lambda args
- (let ((port (current-error-port)))
- (display "Warn: " port)
- (for-each (lambda (x) (display x port)) 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.
diff --git a/makcrc.scm b/makcrc.scm
index 3ea80d5..debd5c9 100644
--- a/makcrc.scm
+++ b/makcrc.scm
@@ -1,9 +1,9 @@
;;;; "makcrc.scm" Compute Cyclic Checksums
-;;; Copyright (C) 1995, 1996, 1997 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -17,27 +17,39 @@
;promotional, or sales literature without prior written consent in
;each case.
+(require 'byte)
(require 'logical)
-;;;(define crc (eval (make-port-crc 16 #o010013)))
-;;;(define crc (eval (make-port-crc 08 #o053)))
-;;;(define (file-check-sum file) (call-with-input-file file crc32))
-
(define (make-port-crc . margs)
(define (make-mask hibit)
(+ (ash (+ -1 (ash 1 (+ 1 (- hibit 2)))) 1) 1))
- (define accum-bits 32)
(define chunk-bits (integer-length (+ -1 char-code-limit)))
+ (define accum-bits #f)
(define generator #f)
- (cond ((pair? margs)
- (set! accum-bits (car margs))
- (cond ((pair? (cdr margs))
- (set! generator (cadr margs))))))
+ (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
- ((32) (set! generator #b00000100110000010001110110110111))
+ ((#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")))))
+ 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)
@@ -69,17 +81,14 @@
(do ((i 0 (+ 1 i)))
((> i chunk-mask))
(vector-set! crctab i (remd i)))))
- (cond ((>= (integer-length generator) accum-bits)
- (slib:error 'make-port-crc
- "generator longer than" accum-bits "bits")))
(make-crc-table)
`(lambda (port)
(define crc 0)
(define byte-count 0)
(define crctab ',crctab)
- (do ((ci (read-char port) (read-char port)))
+ (do ((ci (read-byte port) (read-byte port)))
((eof-object? ci))
- ,(accum '(char->integer ci))
+ ,(accum 'ci)
(set! byte-count (+ 1 byte-count)))
(do ((byte-count byte-count (ash byte-count ,(- chunk-bits))))
((zero? byte-count))
diff --git a/mbe.scm b/mbe.scm
index df88857..8cfe433 100644
--- a/mbe.scm
+++ b/mbe.scm
@@ -1,9 +1,9 @@
;;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/minimize.scm b/minimize.scm
new file mode 100644
index 0000000..50a7e65
--- /dev/null
+++ b/minimize.scm
@@ -0,0 +1,114 @@
+;;; "minimize.scm" finds minimum f(x) for x0 <= x <= x1.
+;;; Author: Lars Arvestad
+;;;
+;;; This code is in the public domain.
+
+;;@noindent
+;;
+;;The Golden Section Search
+;;@footnote{David Kahaner, Cleve Moler, and Stephen Nash
+;;@cite{Numerical Methods and Software}
+;;Prentice-Hall, 1989, ISBN 0-13-627258-4}
+;;algorithm finds minima of functions which
+;;are expensive to compute or for which derivatives are not available.
+;;Although optimum for the general case, convergence is slow,
+;;requiring nearly 100 iterations for the example (x^3-2x-5).
+;;
+;;@noindent
+;;
+;;If the derivative is available, Newton-Raphson is probably a better
+;;choice. If the function is inexpensive to compute, consider
+;;approximating the derivative.
+
+;;@body
+;;
+;;@var{x_0} are @var{x_1} real numbers. The (single argument)
+;;procedure @var{f} is unimodal over the open interval (@var{x_0},
+;;@var{x_1}). That is, there is exactly one point in the interval for
+;;which the derivative of @var{f} is zero.
+;;
+;;@0 returns a pair (@var{x} . @var{f}(@var{x})) where @var{f}(@var{x})
+;;is the minimum. The @var{prec} parameter is the stop criterion. If
+;;@var{prec} is a positive number, then the iteration continues until
+;;@var{x} is within @var{prec} from the true value. If @var{prec} is
+;;a negative integer, then the procedure will iterate @var{-prec}
+;;times or until convergence. If @var{prec} is a procedure of seven
+;;arguments, @var{x0}, @var{x1}, @var{a}, @var{b}, @var{fa}, @var{fb},
+;;and @var{count}, then the iterations will stop when the procedure
+;;returns @code{#t}.
+;;
+;;Analytically, the minimum of x^3-2x-5 is 0.816497.
+;;@example
+;;(define func (lambda (x) (+ (* x (+ (* x x) -2)) -5)))
+;;(golden-section-search func 0 1 (/ 10000))
+;; ==> (816.4883855245578e-3 . -6.0886621077391165)
+;;(golden-section-search func 0 1 -5)
+;; ==> (819.6601125010515e-3 . -6.088637561916407)
+;;(golden-section-search func 0 1
+;; (lambda (a b c d e f g ) (= g 500)))
+;; ==> (816.4965933140557e-3 . -6.088662107903635)
+;;@end example
+
+(define golden-section-search
+ (let ((gss 'golden-section-search:)
+ (r (/ (- (sqrt 5) 1) 2))) ; 1 / golden-section
+ (lambda (f x0 x1 prec)
+ (cond ((not (procedure? f)) (slib:error gss 'procedure? f))
+ ((not (number? x0)) (slib:error gss 'number? x0))
+ ((not (number? x1)) (slib:error gss 'number? x1))
+ ((>= x0 x1) (slib:error gss x0 'not '< x1)))
+ (let ((stop?
+ (cond
+ ((procedure? prec) prec)
+ ((number? prec)
+ (if (>= prec 0)
+ (lambda (x0 x1 a b fa fb count) (<= (abs (- x1 x0)) prec))
+ (if (integer? prec)
+ (lambda (x0 x1 a b fa fb count) (>= count (- prec)))
+ (slib:error gss 'integer? prec))))
+ (else (slib:error gss 'procedure? prec))))
+ (a0 (+ x0 (* (- x1 x0) (- 1 r))))
+ (b0 (+ x0 (* (- x1 x0) r)))
+ (delta #f)
+ (fmax #f)
+ (fmin #f))
+ (let loop ((left x0)
+ (right x1)
+ (a a0)
+ (b b0)
+ (fa (f a0))
+ (fb (f b0))
+ (count 1))
+ (define finish
+ (lambda (x fx)
+ (if (> fx fmin) (slib:warn gss fx 'not 'min (list '> fmin)))
+ (if (and (> count 9) (or (eqv? x0 left) (eqv? x1 right)))
+ (slib:warn gss 'min 'not 'found))
+ (cons x fx)))
+ (case count
+ ((1)
+ (set! fmax (max fa fb))
+ (set! fmin (min fa fb)))
+ ((2)
+ (set! fmin (min fmin fa fb))
+ (if (eqv? fmax fa fb) (slib:error gss 'flat? fmax)))
+ (else
+ (set! fmin (min fmin fa fb))))
+ (cond ((stop? left right a b fa fb count)
+ (if (< fa fb)
+ (finish a fa)
+ (finish b fb)))
+ ((< fa fb)
+ (let ((a-next (+ left (* (- b left) (- 1 r)))))
+ (cond ((and delta (< delta (- b a)))
+ (finish a fa))
+ (else (set! delta (- b a))
+ (loop left b a-next a (f a-next) fa
+ (+ 1 count))))))
+ (else
+ (let ((b-next (+ a (* (- right a) r))))
+ (cond ((and delta (< delta (- b a)))
+ (finish b fb))
+ (else (set! delta (- b a))
+ (loop a right b b-next fb (f b-next)
+ (+ 1 count))))))))))))
diff --git a/minimize.txi b/minimize.txi
new file mode 100644
index 0000000..785be35
--- /dev/null
+++ b/minimize.txi
@@ -0,0 +1,48 @@
+@noindent
+
+The Golden Section Search
+@footnote{David Kahaner, Cleve Moler, and Stephen Nash
+@cite{Numerical Methods and Software}
+Prentice-Hall, 1989, ISBN 0-13-627258-4}
+algorithm finds minima of functions which
+are expensive to compute or for which derivatives are not available.
+Although optimum for the general case, convergence is slow,
+requiring nearly 100 iterations for the example (x^3-2x-5).
+
+@noindent
+
+If the derivative is available, Newton-Raphson is probably a better
+choice. If the function is inexpensive to compute, consider
+approximating the derivative.
+
+
+@defun golden-section-search f x0 x1 prec
+
+
+@var{x_0} are @var{x_1} real numbers. The (single argument)
+procedure @var{f} is unimodal over the open interval (@var{x_0},
+@var{x_1}). That is, there is exactly one point in the interval for
+which the derivative of @var{f} is zero.
+
+@code{golden-section-search} returns a pair (@var{x} . @var{f}(@var{x})) where @var{f}(@var{x})
+is the minimum. The @var{prec} parameter is the stop criterion. If
+@var{prec} is a positive number, then the iteration continues until
+@var{x} is within @var{prec} from the true value. If @var{prec} is
+a negative integer, then the procedure will iterate @var{-prec}
+times or until convergence. If @var{prec} is a procedure of seven
+arguments, @var{x0}, @var{x1}, @var{a}, @var{b}, @var{fa}, @var{fb},
+and @var{count}, then the iterations will stop when the procedure
+returns @code{#t}.
+
+Analytically, the minimum of x^3-2x-5 is 0.816497.
+@example
+(define func (lambda (x) (+ (* x (+ (* x x) -2)) -5)))
+(golden-section-search func 0 1 (/ 10000))
+ ==> (816.4883855245578e-3 . -6.0886621077391165)
+(golden-section-search func 0 1 -5)
+ ==> (819.6601125010515e-3 . -6.088637561916407)
+(golden-section-search func 0 1
+ (lambda (a b c d e f g ) (= g 500)))
+ ==> (816.4965933140557e-3 . -6.088662107903635)
+@end example
+@end defun
diff --git a/mitcomp.pat b/mitcomp.pat
deleted file mode 100644
index 78cb9b9..0000000
--- a/mitcomp.pat
+++ /dev/null
@@ -1,1466 +0,0 @@
-;"mitcomp.pat", patch file of definitions for compiling SLIB with MitScheme.
-;;; Copyright (C) 1993 Matthew McDonald.
-;
-;Permission to copy this software, to redistribute it, and to use it
-;for any purpose is granted, subject to the following restrictions and
-;understandings.
-;
-;1. Any copy made of this software must include this copyright notice
-;in full.
-;
-;2. I have made no warrantee or representation that the operation of
-;this software will be error-free, and I am under no obligation to
-;provide any services, by way of maintenance, update, or otherwise.
-;
-;3. In conjunction with products arising from the use of this
-;material, there shall be no use of my name in any advertising,
-;promotional, or sales literature without prior written consent in
-;each case.
-
-From: mafm@cs.uwa.edu.au (Matthew MCDONALD)
-
- Added declarations to files providing these:
-dynamic alist hash hash-table logical random random-inexact modular
-prime charplot common-list-functions format generic-write pprint-file
-pretty-print-to-string object->string string-case printf line-i/o
-synchk priority-queue process red-black-tree sort
-
-(for-each cf
- '("dynamic.scm" "alist.scm" "hash.scm" "hashtab.scm" "logical.scm"
- "random.scm" "randinex.scm" "modular.scm" "prime.scm" "charplot.scm"
- "comlist.scm" "format.scm" "genwrite.scm" "ppfile.scm" "pp2str.scm"
- "obj2str.scm" "strcase.scm" "printf.scm" "lineio.scm" "synchk.scm"
- "priorque.scm" "process.scm" "rbtree.scm" "sort.scm))
-
-while in the SLIB directory will compile all of these.
-
- They all appear to still be working... They should be
-everything CScheme currently uses (except [1] below.)
-
-NOTES:
-
-[1] Not altered:
- debug Not worth optimising
- test " " "
- fluid-let compiler chokes over
- (lambda () . body)
- scmacro Fails when compiled, not immediately obvious why
- synclo " " "
- r4rsyn " " "
- yasos requires the macros
- collect " " "
-
-[2] removed 'sort from list of MIT features. The library version is
-more complete (and needed for charplot.)
-
-[3] Remember that mitscheme.init gets the .bin put in the wrong place
-by the compiler and thus doesn't get recognised by LOAD.
-======================================================================
-diff -c slib/alist.scm nlib/alist.scm
-*** slib/alist.scm Thu Jan 21 00:01:34 1993
---- nlib/alist.scm Tue Feb 9 00:21:07 1993
-***************
-*** 44,50 ****
- ;(define rem (alist-remover string-ci=?))
- ;(set! alist (rem alist "fOO"))
-
-! (define (predicate->asso pred)
- (cond ((eq? eq? pred) assq)
- ((eq? = pred) assv)
- ((eq? eqv? pred) assv)
---- 44,53 ----
- ;(define rem (alist-remover string-ci=?))
- ;(set! alist (rem alist "fOO"))
-
-! ;;; Declarations for CScheme
-! (declare (usual-integrations))
-!
-! (define-integrable (predicate->asso pred)
- (cond ((eq? eq? pred) assq)
- ((eq? = pred) assv)
- ((eq? eqv? pred) assv)
-***************
-*** 57,69 ****
- ((pred key (caar al)) (car al))
- (else (l (cdr al)))))))))
-
-! (define (alist-inquirer pred)
- (let ((assofun (predicate->asso pred)))
- (lambda (alist key)
- (let ((pair (assofun key alist)))
- (and pair (cdr pair))))))
-
-! (define (alist-associator pred)
- (let ((assofun (predicate->asso pred)))
- (lambda (alist key val)
- (let* ((pair (assofun key alist)))
---- 60,72 ----
- ((pred key (caar al)) (car al))
- (else (l (cdr al)))))))))
-
-! (define-integrable (alist-inquirer pred)
- (let ((assofun (predicate->asso pred)))
- (lambda (alist key)
- (let ((pair (assofun key alist)))
- (and pair (cdr pair))))))
-
-! (define-integrable (alist-associator pred)
- (let ((assofun (predicate->asso pred)))
- (lambda (alist key val)
- (let* ((pair (assofun key alist)))
-***************
-*** 71,77 ****
- alist)
- (else (cons (cons key val) alist)))))))
-
-! (define (alist-remover pred)
- (lambda (alist key)
- (cond ((null? alist) alist)
- ((pred key (caar alist)) (cdr alist))
---- 74,80 ----
- alist)
- (else (cons (cons key val) alist)))))))
-
-! (define-integrable (alist-remover pred)
- (lambda (alist key)
- (cond ((null? alist) alist)
- ((pred key (caar alist)) (cdr alist))
-diff -c slib/charplot.scm nlib/charplot.scm
-*** slib/charplot.scm Sat Nov 14 21:50:54 1992
---- nlib/charplot.scm Tue Feb 9 00:21:07 1993
-***************
-*** 7,12 ****
---- 7,24 ----
- ;are strings with names to label the x and y axii with.
-
- ;;;;---------------------------------------------------------------
-+
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+ (declare (integrate-external "sort"))
-+ (declare (integrate
-+ rows
-+ columns
-+ charplot:height
-+ charplot:width
-+ charplot:plot
-+ plot!))
-+
- (require 'sort)
-
- (define rows 24)
-***************
-*** 27,39 ****
- (write-char char)
- (charplot:printn! (+ n -1) char))))
-
-! (define (charplot:center-print! str width)
- (let ((lpad (quotient (- width (string-length str)) 2)))
- (charplot:printn! lpad #\ )
- (display str)
- (charplot:printn! (- width (+ (string-length str) lpad)) #\ )))
-
-! (define (scale-it z scale)
- (if (and (exact? z) (integer? z))
- (quotient (* z (car scale)) (cadr scale))
- (inexact->exact (round (/ (* z (car scale)) (cadr scale))))))
---- 39,51 ----
- (write-char char)
- (charplot:printn! (+ n -1) char))))
-
-! (define-integrable (charplot:center-print! str width)
- (let ((lpad (quotient (- width (string-length str)) 2)))
- (charplot:printn! lpad #\ )
- (display str)
- (charplot:printn! (- width (+ (string-length str) lpad)) #\ )))
-
-! (define-integrable (scale-it z scale)
- (if (and (exact? z) (integer? z))
- (quotient (* z (car scale)) (cadr scale))
- (inexact->exact (round (/ (* z (car scale)) (cadr scale))))))
-diff -c slib/comlist.scm nlib/comlist.scm
-*** slib/comlist.scm Wed Jan 27 11:08:44 1993
---- nlib/comlist.scm Tue Feb 9 00:21:08 1993
-***************
-*** 6,11 ****
---- 6,14 ----
-
- ;;;; LIST FUNCTIONS FROM COMMON LISP
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+
- ;;;From: hugh@ear.mit.edu (Hugh Secker-Walker)
- (define (make-list k . init)
- (set! init (if (pair? init) (car init)))
-***************
-*** 13,21 ****
- (result '() (cons init result)))
- ((<= k 0) result)))
-
-! (define (copy-list lst) (append lst '()))
-
-! (define (adjoin e l) (if (memq e l) l (cons e l)))
-
- (define (union l1 l2)
- (cond ((null? l1) l2)
---- 16,24 ----
- (result '() (cons init result)))
- ((<= k 0) result)))
-
-! (define-integrable (copy-list lst) (append lst '()))
-
-! (define-integrable (adjoin e l) (if (memq e l) l (cons e l)))
-
- (define (union l1 l2)
- (cond ((null? l1) l2)
-***************
-*** 33,39 ****
- ((memv (car l1) l2) (set-difference (cdr l1) l2))
- (else (cons (car l1) (set-difference (cdr l1) l2)))))
-
-! (define (position obj lst)
- (letrec ((pos (lambda (n lst)
- (cond ((null? lst) #f)
- ((eqv? obj (car lst)) n)
---- 36,42 ----
- ((memv (car l1) l2) (set-difference (cdr l1) l2))
- (else (cons (car l1) (set-difference (cdr l1) l2)))))
-
-! (define-integrable (position obj lst)
- (letrec ((pos (lambda (n lst)
- (cond ((null? lst) #f)
- ((eqv? obj (car lst)) n)
-***************
-*** 45,51 ****
- init
- (reduce-init p (p init (car l)) (cdr l))))
-
-! (define (reduce p l)
- (cond ((null? l) l)
- ((null? (cdr l)) (car l))
- (else (reduce-init p (car l) (cdr l)))))
---- 48,54 ----
- init
- (reduce-init p (p init (car l)) (cdr l))))
-
-! (define-integrable (reduce p l)
- (cond ((null? l) l)
- ((null? (cdr l)) (car l))
- (else (reduce-init p (car l) (cdr l)))))
-***************
-*** 58,64 ****
- (or (null? l)
- (and (pred (car l)) (every pred (cdr l)))))
-
-! (define (notevery pred l) (not (every pred l)))
-
- (define (find-if t l)
- (cond ((null? l) #f)
---- 61,67 ----
- (or (null? l)
- (and (pred (car l)) (every pred (cdr l)))))
-
-! (define-integrable (notevery pred l) (not (every pred l)))
-
- (define (find-if t l)
- (cond ((null? l) #f)
-***************
-*** 121,141 ****
- (define (nthcdr n lst)
- (if (zero? n) lst (nthcdr (+ -1 n) (cdr lst))))
-
-! (define (last lst n)
- (nthcdr (- (length lst) n) lst))
-
- ;;;; CONDITIONALS
-
-! (define (and? . args)
- (cond ((null? args) #t)
- ((car args) (apply and? (cdr args)))
- (else #f)))
-
-! (define (or? . args)
- (cond ((null? args) #f)
- ((car args) #t)
- (else (apply or? (cdr args)))))
-
-! (define (identity x) x)
-
- (require 'rev3-procedures)
---- 124,144 ----
- (define (nthcdr n lst)
- (if (zero? n) lst (nthcdr (+ -1 n) (cdr lst))))
-
-! (define-integrable (last lst n)
- (nthcdr (- (length lst) n) lst))
-
- ;;;; CONDITIONALS
-
-! (define-integrable (and? . args)
- (cond ((null? args) #t)
- ((car args) (apply and? (cdr args)))
- (else #f)))
-
-! (define-integrable (or? . args)
- (cond ((null? args) #f)
- ((car args) #t)
- (else (apply or? (cdr args)))))
-
-! (define-integrable (identity x) x)
-
- (require 'rev3-procedures)
-diff -c slib/dynamic.scm nlib/dynamic.scm
-*** slib/dynamic.scm Thu Sep 17 23:35:46 1992
---- nlib/dynamic.scm Tue Feb 9 00:21:08 1993
-***************
-*** 31,36 ****
---- 31,43 ----
- ;
- ;There was also a DYNAMIC-BIND macro which I haven't implemented.
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+
-+ (declare (integrate-external "record"))
-+ (declare (integrate-external "dynwind"))
-+ (declare (integrate dynamic:errmsg))
-+
- (require 'record)
- (require 'dynamic-wind)
-
-***************
-*** 48,60 ****
- (record-accessor dynamic-environment-rtd 'parent))
-
- (define *current-dynamic-environment* #f)
-! (define (extend-current-dynamic-environment dynamic obj)
- (set! *current-dynamic-environment*
- (make-dynamic-environment dynamic obj
- *current-dynamic-environment*)))
-
- (define dynamic-rtd (make-record-type "dynamic" '()))
-! (define make-dynamic
- (let ((dynamic-constructor (record-constructor dynamic-rtd)))
- (lambda (obj)
- (let ((dynamic (dynamic-constructor)))
---- 55,69 ----
- (record-accessor dynamic-environment-rtd 'parent))
-
- (define *current-dynamic-environment* #f)
-!
-! (define-integrable (extend-current-dynamic-environment dynamic obj)
- (set! *current-dynamic-environment*
- (make-dynamic-environment dynamic obj
- *current-dynamic-environment*)))
-
- (define dynamic-rtd (make-record-type "dynamic" '()))
-!
-! (define-integrable make-dynamic
- (let ((dynamic-constructor (record-constructor dynamic-rtd)))
- (lambda (obj)
- (let ((dynamic (dynamic-constructor)))
-***************
-*** 61,68 ****
- (extend-current-dynamic-environment dynamic obj)
- dynamic))))
-
-! (define dynamic? (record-predicate dynamic-rtd))
-! (define (guarantee-dynamic dynamic)
- (or (dynamic? dynamic)
- (slib:error "Not a dynamic" dynamic)))
-
---- 70,78 ----
- (extend-current-dynamic-environment dynamic obj)
- dynamic))))
-
-! (define-integrable dynamic? (record-predicate dynamic-rtd))
-!
-! (define-integrable (guarantee-dynamic dynamic)
- (or (dynamic? dynamic)
- (slib:error "Not a dynamic" dynamic)))
-
-***************
-*** 69,75 ****
- (define dynamic:errmsg
- "No value defined for this dynamic in the current dynamic environment")
-
-! (define (dynamic-ref dynamic)
- (guarantee-dynamic dynamic)
- (let loop ((env *current-dynamic-environment*))
- (cond ((not env)
---- 79,85 ----
- (define dynamic:errmsg
- "No value defined for this dynamic in the current dynamic environment")
-
-! (define-integrable (dynamic-ref dynamic)
- (guarantee-dynamic dynamic)
- (let loop ((env *current-dynamic-environment*))
- (cond ((not env)
-***************
-*** 79,85 ****
- (else
- (loop (dynamic-environment:parent env))))))
-
-! (define (dynamic-set! dynamic obj)
- (guarantee-dynamic dynamic)
- (let loop ((env *current-dynamic-environment*))
- (cond ((not env)
---- 89,95 ----
- (else
- (loop (dynamic-environment:parent env))))))
-
-! (define-integrable (dynamic-set! dynamic obj)
- (guarantee-dynamic dynamic)
- (let loop ((env *current-dynamic-environment*))
- (cond ((not env)
-diff -c slib/format.scm nlib/format.scm
-*** slib/format.scm Tue Jan 5 14:56:48 1993
---- nlib/format.scm Tue Feb 9 00:21:09 1993
-***************
-*** 78,84 ****
- ; * removed C-style padding support
- ;
-
-! ;;; SCHEME IMPLEMENTATION DEPENDENCIES ---------------------------------------
-
- ;; To configure the format module for your scheme system, set the variable
- ;; format:scheme-system to one of the symbols of (slib elk any). You may add
---- 78,88 ----
- ; * removed C-style padding support
- ;
-
-! ;;; SCHEME IMPLEMENTATION DEPENDENCIES
-! ;;; ---------------------------------------
-!
-! ;;; (minimal) Declarations for CScheme
-! (declare (usual-integrations))
-
- ;; To configure the format module for your scheme system, set the variable
- ;; format:scheme-system to one of the symbols of (slib elk any). You may add
-diff -c slib/genwrite.scm nlib/genwrite.scm
-*** slib/genwrite.scm Mon Oct 19 14:49:06 1992
---- nlib/genwrite.scm Tue Feb 9 00:21:10 1993
-***************
-*** 26,31 ****
---- 26,34 ----
- ;
- ; where display-string = (lambda (s) (for-each write-char (string->list s)) #t)
-
-+ ;;; (minimal) Declarations for CScheme
-+ (declare (usual-integrations))
-+
- (define (generic-write obj display? width output)
-
- (define (read-macro? l)
-diff -c slib/hash.scm nlib/hash.scm
-*** slib/hash.scm Thu Sep 10 00:05:52 1992
---- nlib/hash.scm Tue Feb 9 00:21:10 1993
-***************
-*** 23,35 ****
- ;the equality predicate pred. Pred should be EQ?, EQV?, EQUAL?, =,
- ;CHAR=?, CHAR-CI=?, STRING=?, or STRING-CI=?.
-
-! (define (hash:hash-char char n)
- (modulo (char->integer char) n))
-
-! (define (hash:hash-char-ci char n)
- (modulo (char->integer (char-downcase char)) n))
-
-! (define (hash:hash-symbol sym n)
- (hash:hash-string (symbol->string sym) n))
-
- ;;; I am trying to be careful about overflow and underflow here.
---- 23,40 ----
- ;the equality predicate pred. Pred should be EQ?, EQV?, EQUAL?, =,
- ;CHAR=?, CHAR-CI=?, STRING=?, or STRING-CI=?.
-
-!
-! ;;; Declarations for CScheme
-! (declare (usual-integrations))
-! (declare (integrate hash))
-!
-! (define-integrable (hash:hash-char char n)
- (modulo (char->integer char) n))
-
-! (define-integrable (hash:hash-char-ci char n)
- (modulo (char->integer (char-downcase char)) n))
-
-! (define-integrable (hash:hash-symbol sym n)
- (hash:hash-string (symbol->string sym) n))
-
- ;;; I am trying to be careful about overflow and underflow here.
-***************
-*** 173,179 ****
-
- (define hashq hashv)
-
-! (define (predicate->hash pred)
- (cond ((eq? pred eq?) hashq)
- ((eq? pred eqv?) hashv)
- ((eq? pred equal?) hash)
---- 178,184 ----
-
- (define hashq hashv)
-
-! (define-integrable (predicate->hash pred)
- (cond ((eq? pred eq?) hashq)
- ((eq? pred eqv?) hashv)
- ((eq? pred equal?) hash)
-diff -c slib/hashtab.scm nlib/hashtab.scm
-*** slib/hashtab.scm Mon Oct 19 14:49:44 1992
---- nlib/hashtab.scm Tue Feb 9 00:21:11 1993
-***************
-*** 36,47 ****
- ;Returns a procedure of 2 arguments, hashtab and key, which modifies
- ;hashtab so that the association whose key is key removed.
-
- (require 'hash)
- (require 'alist)
-
-! (define (make-hash-table k) (make-vector k '()))
-
-! (define (predicate->hash-asso pred)
- (let ((hashfun (predicate->hash pred))
- (asso (predicate->asso pred)))
- (lambda (key hashtab)
---- 36,53 ----
- ;Returns a procedure of 2 arguments, hashtab and key, which modifies
- ;hashtab so that the association whose key is key removed.
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+
-+ (declare (integrate-external "hash"))
-+ (declare (integrate-external "alist"))
-+
- (require 'hash)
- (require 'alist)
-
-! (define-integrable (make-hash-table k) (make-vector k '()))
-
-! (define-integrable (predicate->hash-asso pred)
- (let ((hashfun (predicate->hash pred))
- (asso (predicate->asso pred)))
- (lambda (key hashtab)
-***************
-*** 48,54 ****
- (asso key
- (vector-ref hashtab (hashfun key (vector-length hashtab)))))))
-
-! (define (hash-inquirer pred)
- (let ((hashfun (predicate->hash pred))
- (ainq (alist-inquirer pred)))
- (lambda (hashtab key)
---- 54,60 ----
- (asso key
- (vector-ref hashtab (hashfun key (vector-length hashtab)))))))
-
-! (define-integrable (hash-inquirer pred)
- (let ((hashfun (predicate->hash pred))
- (ainq (alist-inquirer pred)))
- (lambda (hashtab key)
-***************
-*** 55,61 ****
- (ainq (vector-ref hashtab (hashfun key (vector-length hashtab)))
- key))))
-
-! (define (hash-associator pred)
- (let ((hashfun (predicate->hash pred))
- (asso (alist-associator pred)))
- (lambda (hashtab key val)
---- 61,67 ----
- (ainq (vector-ref hashtab (hashfun key (vector-length hashtab)))
- key))))
-
-! (define-integrable (hash-associator pred)
- (let ((hashfun (predicate->hash pred))
- (asso (alist-associator pred)))
- (lambda (hashtab key val)
-***************
-*** 64,70 ****
- (asso (vector-ref hashtab num) key val)))
- hashtab)))
-
-! (define (hash-remover pred)
- (let ((hashfun (predicate->hash pred))
- (arem (alist-remover pred)))
- (lambda (hashtab key)
---- 70,76 ----
- (asso (vector-ref hashtab num) key val)))
- hashtab)))
-
-! (define-integrable (hash-remover pred)
- (let ((hashfun (predicate->hash pred))
- (arem (alist-remover pred)))
- (lambda (hashtab key)
-diff -c slib/lineio.scm nlib/lineio.scm
-*** slib/lineio.scm Sun Oct 25 01:40:38 1992
---- nlib/lineio.scm Tue Feb 9 00:21:11 1993
-***************
-*** 28,33 ****
---- 28,36 ----
- ;unspecified value. Port may be ommited, in which case it defaults to
- ;the value returned by current-input-port.
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+
- (define (read-line . arg)
- (let* ((char (apply read-char arg)))
- (if (eof-object? char)
-***************
-*** 56,61 ****
- (+ 1 i) #f))))
- (string-set! str i char)))))
-
-! (define (write-line str . arg)
- (apply display str arg)
- (apply newline arg))
---- 59,64 ----
- (+ 1 i) #f))))
- (string-set! str i char)))))
-
-! (define-integrable (write-line str . arg)
- (apply display str arg)
- (apply newline arg))
-diff -c slib/logical.scm nlib/logical.scm
-*** slib/logical.scm Mon Feb 1 22:22:04 1993
---- nlib/logical.scm Tue Feb 9 00:21:11 1993
-***************
-*** 48,53 ****
---- 48,66 ----
- ;
- ;;;;------------------------------------------------------------------
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+ (declare (integrate logand ; Exported functions
-+ logor
-+ logxor
-+ lognot
-+ ash
-+ logcount
-+ integer-length
-+ bit-extract
-+ ipow-by-squaring
-+ integer-expt))
-+
- (define logical:integer-expt
- (if (provided? 'inexact)
- expt
-***************
-*** 61,67 ****
- (quotient k 2)
- (if (even? k) acc (proc acc x))
- proc))))
--
- (define (logical:logand n1 n2)
- (cond ((= n1 n2) n1)
- ((zero? n1) 0)
---- 74,79 ----
-***************
-*** 90,102 ****
- (vector-ref (vector-ref logical:boole-xor (modulo n1 16))
- (modulo n2 16))))))
-
-! (define (logical:lognot n) (- -1 n))
-
-! (define (logical:bit-extract n start end)
- (logical:logand (- (logical:integer-expt 2 (- end start)) 1)
- (logical:ash n (- start))))
-
-! (define (logical:ash int cnt)
- (if (negative? cnt)
- (let ((n (logical:integer-expt 2 (- cnt))))
- (if (negative? int)
---- 102,114 ----
- (vector-ref (vector-ref logical:boole-xor (modulo n1 16))
- (modulo n2 16))))))
-
-! (define-integrable (logical:lognot n) (- -1 n))
-
-! (define-integrable (logical:bit-extract n start end)
- (logical:logand (- (logical:integer-expt 2 (- end start)) 1)
- (logical:ash n (- start))))
-
-! (define-integrable (logical:ash int cnt)
- (if (negative? cnt)
- (let ((n (logical:integer-expt 2 (- cnt))))
- (if (negative? int)
-***************
-*** 104,110 ****
- (quotient int n)))
- (* (logical:integer-expt 2 cnt) int)))
-
-! (define (logical:ash-4 x)
- (if (negative? x)
- (+ -1 (quotient (+ 1 x) 16))
- (quotient x 16)))
---- 116,122 ----
- (quotient int n)))
- (* (logical:integer-expt 2 cnt) int)))
-
-! (define-integrable (logical:ash-4 x)
- (if (negative? x)
- (+ -1 (quotient (+ 1 x) 16))
- (quotient x 16)))
-diff -c slib/mitscheme.init nlib/mitscheme.init
-*** slib/mitscheme.init Fri Jan 22 00:52:04 1993
---- nlib/mitscheme.init Tue Feb 9 00:21:12 1993
-***************
-*** 48,55 ****
-
- ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
- ;;; use this definition if your system doesn't have such a procedure.
-! ;(define (force-output . arg) #t)
-! (define force-output flush-output)
-
- ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
- ;;; be returned by CHAR->INTEGER. It is defined by MITScheme.
---- 47,54 ----
-
- ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
- ;;; use this definition if your system doesn't have such a procedure.
-! (define (force-output . arg) #t)
-! ;(define force-output flush-output)
-
- ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
- ;;; be returned by CHAR->INTEGER. It is defined by MITScheme.
-diff -c slib/modular.scm nlib/modular.scm
-*** slib/modular.scm Sun Feb 2 12:53:26 1992
---- nlib/modular.scm Tue Feb 9 00:21:13 1993
-***************
-*** 36,41 ****
---- 36,48 ----
- ;Returns (k2 ^ k3) mod k1.
- ;
- ;;;;--------------------------------------------------------------
-+
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+
-+ (declare (integrate-external "logical"))
-+ (declare (integrate modular:negate extended-euclid))
-+
- (require 'logical)
-
- ;;; from:
-***************
-*** 51,57 ****
- (caddr res)
- (- (cadr res) (* (quotient a b) (caddr res)))))))
-
-! (define (modular:invert m a)
- (let ((d (modular:extended-euclid a m)))
- (if (= 1 (car d))
- (modulo (cadr d) m)
---- 58,64 ----
- (caddr res)
- (- (cadr res) (* (quotient a b) (caddr res)))))))
-
-! (define-integrable (modular:invert m a)
- (let ((d (modular:extended-euclid a m)))
- (if (= 1 (car d))
- (modulo (cadr d) m)
-***************
-*** 59,67 ****
-
- (define modular:negate -)
-
-! (define (modular:+ m a b) (modulo (+ (- a m) b) m))
-
-! (define (modular:- m a b) (modulo (- a b) m))
-
- ;;; See: L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
- ;;; with Splitting Facilities." ACM Transactions on Mathematical
---- 66,74 ----
-
- (define modular:negate -)
-
-! (define-integrable (modular:+ m a b) (modulo (+ (- a m) b) m))
-
-! (define-integrable (modular:- m a b) (modulo (- a b) m))
-
- ;;; See: L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
- ;;; with Splitting Facilities." ACM Transactions on Mathematical
-***************
-*** 98,104 ****
- (modulo (+ (if (positive? p) (- p m) p)
- (* a0 (modulo b q))) m)))))
-
-! (define (modular:expt m a b)
- (cond ((= a 1) 1)
- ((= a (- m 1)) (if (odd? b) a 1))
- ((zero? a) 0)
---- 105,111 ----
- (modulo (+ (if (positive? p) (- p m) p)
- (* a0 (modulo b q))) m)))))
-
-! (define-integrable (modular:expt m a b)
- (cond ((= a 1) 1)
- ((= a (- m 1)) (if (odd? b) a 1))
- ((zero? a) 0)
-diff -c slib/obj2str.scm nlib/obj2str.scm
-*** slib/obj2str.scm Mon Oct 19 14:49:08 1992
---- nlib/obj2str.scm Tue Feb 9 00:21:13 1993
-***************
-*** 2,13 ****
-
- (require 'generic-write)
-
- ; (object->string obj) returns the textual representation of 'obj' as a
- ; string.
- ;
- ; Note: (write obj) = (display (object->string obj))
-
-! (define (object->string obj)
- (let ((result '()))
- (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t))
- (reverse-string-append result)))
---- 2,17 ----
-
- (require 'generic-write)
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+ (declare (integrate-external "genwrite"))
-+
- ; (object->string obj) returns the textual representation of 'obj' as a
- ; string.
- ;
- ; Note: (write obj) = (display (object->string obj))
-
-! (define-integrable (object->string obj)
- (let ((result '()))
- (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t))
- (reverse-string-append result)))
-diff -c slib/pp2str.scm nlib/pp2str.scm
-*** slib/pp2str.scm Mon Oct 19 14:49:08 1992
---- nlib/pp2str.scm Tue Feb 9 00:21:13 1993
-***************
-*** 2,11 ****
-
- (require 'generic-write)
-
- ; (pretty-print-to-string obj) returns a string with the pretty-printed
- ; textual representation of 'obj'.
-
-! (define (pp:pretty-print-to-string obj)
- (let ((result '()))
- (generic-write obj #f 79 (lambda (str) (set! result (cons str result)) #t))
- (reverse-string-append result)))
---- 2,16 ----
-
- (require 'generic-write)
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+ (declare (integrate-external "genwrite"))
-+ (declare (integrate pretty-print-to-string))
-+
- ; (pretty-print-to-string obj) returns a string with the pretty-printed
- ; textual representation of 'obj'.
-
-! (define-integrable (pp:pretty-print-to-string obj)
- (let ((result '()))
- (generic-write obj #f 79 (lambda (str) (set! result (cons str result)) #t))
- (reverse-string-append result)))
-diff -c slib/ppfile.scm nlib/ppfile.scm
-*** slib/ppfile.scm Mon Oct 19 14:49:08 1992
---- nlib/ppfile.scm Tue Feb 9 00:21:14 1993
-***************
-*** 10,15 ****
---- 10,19 ----
- ;
- (require 'pretty-print)
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+ (declare (integrate-external "pp"))
-+
- (define (pprint-file ifile . optarg)
- (let ((lst (call-with-input-file ifile
- (lambda (iport)
-diff -c slib/prime.scm nlib/prime.scm
-*** slib/prime.scm Mon Feb 8 20:49:46 1993
---- nlib/prime.scm Tue Feb 9 00:24:16 1993
-***************
-*** 24,29 ****
---- 24,39 ----
- ;(sort! (factor k) <)
-
- ;;;;--------------------------------------------------------------
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+ (declare (integrate-external "random"))
-+ (declare (integrate-external "modular"))
-+ (declare (integrate
-+ jacobi-symbol
-+ prime?
-+ factor))
-+
-+
- (require 'random)
- (require 'modular)
-
-***************
-*** 56,62 ****
- ;;; choosing prime:trials=30 should be enough
- (define prime:trials 30)
- ;;; prime:product is a product of small primes.
-! (define prime:product
- (let ((p 210))
- (for-each (lambda (s) (set! p (or (string->number s) p)))
- '("2310" "30030" "510510" "9699690" "223092870"
---- 66,72 ----
- ;;; choosing prime:trials=30 should be enough
- (define prime:trials 30)
- ;;; prime:product is a product of small primes.
-! (define-integrable prime:product
- (let ((p 210))
- (for-each (lambda (s) (set! p (or (string->number s) p)))
- '("2310" "30030" "510510" "9699690" "223092870"
-***************
-*** 86,92 ****
- ; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even
-
- ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m.
-!
- ;It may be illuminating to consider the relation of the Lankinen function in
- ;a `computational hierarchy' of other factoring functions.* Assumptions are
- ;made herein on the basis of conventional digital (binary) computers. Also,
---- 96,102 ----
- ; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even
-
- ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m.
-!
- ;It may be illuminating to consider the relation of the Lankinen function in
- ;a `computational hierarchy' of other factoring functions.* Assumptions are
- ;made herein on the basis of conventional digital (binary) computers. Also,
-***************
-*** 94,100 ****
- ;be factored is prime). However, all algorithms would probably perform to
- ;the same constant multiple of the given orders for complete composite
- ;factorizations.
-!
- ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and
- ; O(n*log2(n)) in space.
- ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime
---- 104,110 ----
- ;be factored is prime). However, all algorithms would probably perform to
- ;the same constant multiple of the given orders for complete composite
- ;factorizations.
-!
- ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and
- ; O(n*log2(n)) in space.
- ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime
-diff -c slib/priorque.scm nlib/priorque.scm
-*** slib/priorque.scm Mon Oct 19 14:49:42 1992
---- nlib/priorque.scm Tue Feb 9 00:21:15 1993
-***************
-*** 22,41 ****
- ;;; 1989 MIT Press.
-
- (require 'record)
- (define heap-rtd (make-record-type "heap" '(array size heap<?)))
-! (define make-heap
- (let ((cstr (record-constructor heap-rtd)))
- (lambda (pred<?)
- (cstr (make-vector 4) 0 pred<?))))
-! (define heap-ref
- (let ((ra (record-accessor heap-rtd 'array)))
- (lambda (a i)
- (vector-ref (ra a) (+ -1 i)))))
-! (define heap-set!
- (let ((ra (record-accessor heap-rtd 'array)))
- (lambda (a i v)
- (vector-set! (ra a) (+ -1 i) v))))
-! (define heap-exchange
- (let ((aa (record-accessor heap-rtd 'array)))
- (lambda (a i j)
- (set! i (+ -1 i))
---- 22,53 ----
- ;;; 1989 MIT Press.
-
- (require 'record)
-+
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+
-+ (declare (integrate
-+ heap-size
-+ heap<?))
-+
- (define heap-rtd (make-record-type "heap" '(array size heap<?)))
-!
-! (define-integrable make-heap
- (let ((cstr (record-constructor heap-rtd)))
- (lambda (pred<?)
- (cstr (make-vector 4) 0 pred<?))))
-!
-! (define-integrable heap-ref
- (let ((ra (record-accessor heap-rtd 'array)))
- (lambda (a i)
- (vector-ref (ra a) (+ -1 i)))))
-!
-! (define-integrable heap-set!
- (let ((ra (record-accessor heap-rtd 'array)))
- (lambda (a i v)
- (vector-set! (ra a) (+ -1 i) v))))
-!
-! (define-integrable heap-exchange
- (let ((aa (record-accessor heap-rtd 'array)))
- (lambda (a i j)
- (set! i (+ -1 i))
-***************
-*** 44,51 ****
---- 56,66 ----
- (tmp (vector-ref ra i)))
- (vector-set! ra i (vector-ref ra j))
- (vector-set! ra j tmp)))))
-+
- (define heap-size (record-accessor heap-rtd 'size))
-+
- (define heap<? (record-accessor heap-rtd 'heap<?))
-+
- (define heap-set-size
- (let ((aa (record-accessor heap-rtd 'array))
- (am (record-modifier heap-rtd 'array))
-***************
-*** 59,68 ****
- (vector-set! nra i (vector-ref ra i)))))
- (sm a s)))))
-
-! (define (heap-parent i) (quotient i 2))
-! (define (heap-left i) (* 2 i))
-! (define (heap-right i) (+ 1 (* 2 i)))
-
- (define (heapify a i)
- (define l (heap-left i))
- (define r (heap-right i))
---- 74,85 ----
- (vector-set! nra i (vector-ref ra i)))))
- (sm a s)))))
-
-! (define-integrable (heap-parent i) (quotient i 2))
-
-+ (define-integrable (heap-left i) (* 2 i))
-+
-+ (define-integrable (heap-right i) (+ 1 (* 2 i)))
-+
- (define (heapify a i)
- (define l (heap-left i))
- (define r (heap-right i))
-***************
-*** 99,104 ****
---- 116,122 ----
- max))
-
- (define heap #f)
-+
- (define (heap-test)
- (set! heap (make-heap char>?))
- (heap-insert! heap #\A)
-diff -c slib/process.scm nlib/process.scm
-*** slib/process.scm Wed Nov 4 12:26:50 1992
---- nlib/process.scm Tue Feb 9 00:21:15 1993
-***************
-*** 21,30 ****
- ;
- ;;;;----------------------------------------------------------------------
-
- (require 'full-continuation)
- (require 'queue)
-
-! (define (add-process! thunk1)
- (cond ((procedure? thunk1)
- (defer-ints)
- (enqueue! process:queue thunk1)
---- 21,33 ----
- ;
- ;;;;----------------------------------------------------------------------
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+
- (require 'full-continuation)
- (require 'queue)
-
-! (define-integrable (add-process! thunk1)
- (cond ((procedure? thunk1)
- (defer-ints)
- (enqueue! process:queue thunk1)
-***************
-*** 55,63 ****
- (define ints-disabled #f)
- (define alarm-deferred #f)
-
-! (define (defer-ints) (set! ints-disabled #t))
-
-! (define (allow-ints)
- (set! ints-disabled #f)
- (cond (alarm-deferred
- (set! alarm-deferred #f)
---- 58,66 ----
- (define ints-disabled #f)
- (define alarm-deferred #f)
-
-! (define-integrable (defer-ints) (set! ints-disabled #t))
-
-! (define-integrable (allow-ints)
- (set! ints-disabled #f)
- (cond (alarm-deferred
- (set! alarm-deferred #f)
-***************
-*** 66,72 ****
- ;;; Make THE process queue.
- (define process:queue (make-queue))
-
-! (define (alarm-interrupt)
- (alarm 1)
- (if ints-disabled (set! alarm-deferred #t)
- (process:schedule!)))
---- 69,75 ----
- ;;; Make THE process queue.
- (define process:queue (make-queue))
-
-! (define-integrable (alarm-interrupt)
- (alarm 1)
- (if ints-disabled (set! alarm-deferred #t)
- (process:schedule!)))
-diff -c slib/randinex.scm nlib/randinex.scm
-*** slib/randinex.scm Wed Nov 18 22:59:20 1992
---- nlib/randinex.scm Tue Feb 9 00:21:16 1993
-***************
-*** 47,52 ****
---- 47,59 ----
- ;For an exponential distribution with mean U use (* U (random:exp)).
- ;;;;-----------------------------------------------------------------
-
-+
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+ (declare (integrate-external "random"))
-+ (declare (integrate
-+ random:float-radix))
-+
- (define random:float-radix
- (+ 1 (exact->inexact random:MASK)))
-
-***************
-*** 56,61 ****
---- 63,69 ----
- (if (= 1.0 (+ 1 x))
- l
- (random:size-float (+ l 1) (/ x random:float-radix))))
-+
- (define random:chunks/float (random:size-float 1 1.0))
-
- (define (random:uniform-chunk n state)
-***************
-*** 67,73 ****
- random:float-radix)))
-
- ;;; Generate an inexact real between 0 and 1.
-! (define (random:uniform state)
- (random:uniform-chunk random:chunks/float state))
-
- ;;; If x and y are independent standard normal variables, then with
---- 75,81 ----
- random:float-radix)))
-
- ;;; Generate an inexact real between 0 and 1.
-! (define-integrable (random:uniform state)
- (random:uniform-chunk random:chunks/float state))
-
- ;;; If x and y are independent standard normal variables, then with
-***************
-*** 89,95 ****
- (do! n (* r (cos t)))
- (if (positive? n) (do! (- n 1) (* r (sin t)))))))))
-
-! (define random:normal
- (let ((vect (make-vector 1)))
- (lambda args
- (apply random:normal-vector! vect args)
---- 97,103 ----
- (do! n (* r (cos t)))
- (if (positive? n) (do! (- n 1) (* r (sin t)))))))))
-
-! (define-integrable random:normal
- (let ((vect (make-vector 1)))
- (lambda args
- (apply random:normal-vector! vect args)
-***************
-*** 98,104 ****
- ;;; For the uniform distibution on the hollow sphere, pick a normal
- ;;; family and scale.
-
-! (define (random:hollow-sphere! vect . args)
- (let ((ms (sqrt (apply random:normal-vector! vect args))))
- (do ((n (- (vector-length vect) 1) (- n 1)))
- ((negative? n))
---- 106,112 ----
- ;;; For the uniform distibution on the hollow sphere, pick a normal
- ;;; family and scale.
-
-! (define-integrable (random:hollow-sphere! vect . args)
- (let ((ms (sqrt (apply random:normal-vector! vect args))))
- (do ((n (- (vector-length vect) 1) (- n 1)))
- ((negative? n))
-***************
-*** 117,123 ****
- ((negative? n))
- (vector-set! vect n (* r (vector-ref vect n))))))
-
-! (define (random:exp . args)
- (let ((state (if (null? args) *random-state* (car args))))
- (- (log (random:uniform state)))))
-
---- 125,131 ----
- ((negative? n))
- (vector-set! vect n (* r (vector-ref vect n))))))
-
-! (define-integrable (random:exp . args)
- (let ((state (if (null? args) *random-state* (car args))))
- (- (log (random:uniform state)))))
-
-diff -c slib/random.scm nlib/random.scm
-*** slib/random.scm Tue Feb 2 00:02:58 1993
---- nlib/random.scm Tue Feb 9 00:21:18 1993
-***************
-*** 35,40 ****
---- 35,50 ----
- ;procedures for generating inexact distributions.
- ;;;;------------------------------------------------------------------
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+ (declare (integrate-external "logical"))
-+ (declare (integrateb
-+ random:tap-1
-+ random:size
-+ random:chunk-size
-+ random:MASK
-+ random))
-+
- (require 'logical)
-
- (define random:tap 24)
-***************
-*** 45,50 ****
---- 55,61 ----
- (if (and (exact? trial) (>= most-positive-fixnum trial))
- l
- (random:size-int (- l 1)))))
-+
- (define random:chunk-size (* 4 (random:size-int 8)))
-
- (define random:MASK
-***************
-*** 107,113 ****
- ;;;random:uniform is in randinex.scm. It is needed only if inexact is
- ;;;supported.
-
-! (define (random:make-random-state . args)
- (let ((state (if (null? args) *random-state* (car args))))
- (list->vector (vector->list state))))
-
---- 118,124 ----
- ;;;random:uniform is in randinex.scm. It is needed only if inexact is
- ;;;supported.
-
-! (define-integrable (random:make-random-state . args)
- (let ((state (if (null? args) *random-state* (car args))))
- (list->vector (vector->list state))))
-
-diff -c slib/rbtree.scm nlib/rbtree.scm
-*** slib/rbtree.scm Sat Jan 9 13:40:56 1993
---- nlib/rbtree.scm Tue Feb 9 00:21:18 1993
-***************
-*** 5,11 ****
---- 5,24 ----
- ;;;; PGS, 6 Jul 1990
- ;;; jaffer@ai.mit.edu Ported to SLIB, 1/6/93
-
-+
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+ (declare (integrate
-+ rb-tree-root
-+ set-rb-tree-root!
-+ rb-tree-left-rotation-field-maintainer
-+ rb-tree-right-rotation-field-maintainer
-+ rb-tree-insertion-field-maintainer
-+ rb-tree-deletion-field-maintainer
-+ rb-tree-prior?))
-+
- (require 'record)
-+
- (define rb-tree
- (make-record-type
- "rb-tree"
-***************
-*** 227,233 ****
- y)
- (set! x y)
- (set! y (rb-node-parent y)))))
--
-
- ;;;; Deletion. We do not entirely follow Cormen, Leiserson and Rivest's lead
- ;;;; here, because their use of sentinels is in rather obscenely poor taste.
---- 240,245 ----
-diff -c slib/sort.scm nlib/sort.scm
-*** slib/sort.scm Wed Nov 6 00:50:38 1991
---- nlib/sort.scm Tue Feb 9 00:22:03 1993
-***************
-*** 118,123 ****
---- 118,125 ----
- ; in Scheme.
- ;;; --------------------------------------------------------------------
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations)) ; Honestly, nothing defined here clashes!
-
- ;;; (sorted? sequence less?)
- ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
-diff -c slib/printf.scm nlib/printf.scm
-*** slib/printf.scm Mon Oct 19 14:48:58 1992
---- nlib/printf.scm Tue Feb 9 00:22:03 1993
-***************
-*** 3,8 ****
---- 3,19 ----
-
- ;;; Floating point is not handled yet. It should not be hard to do.
-
-+ ;;; Declarations for CScheme
-+ (declare (usual-integrations))
-+
-+ (declare (integrate
-+ printf
-+ fprintf
-+ sprintf
-+ stdin
-+ stdout
-+ stderr))
-+
- (define (stdio:iprintf out format . args)
- (let loop ((pos 0) (args args))
- (if (< pos (string-length format))
-***************
-*** 96,105 ****
- (else (out (string-ref format pos))
- (loop (+ pos 1) args))))))
-
-! (define (stdio:printf format . args)
- (apply stdio:iprintf display format args))
-
-! (define (stdio:fprintf port format . args)
- (if (equal? port (current-output-port))
- (apply stdio:iprintf display format args)
- (apply stdio:iprintf (lambda (x) (display x port)) format args)))
---- 107,116 ----
- (else (out (string-ref format pos))
- (loop (+ pos 1) args))))))
-
-! (define-integrable (stdio:printf format . args)
- (apply stdio:iprintf display format args))
-
-! (define-integrable (stdio:fprintf port format . args)
- (if (equal? port (current-output-port))
- (apply stdio:iprintf display format args)
- (apply stdio:iprintf (lambda (x) (display x port)) format args)))
-diff -c slib/strcase.scm nlib/strcase.scm
-*** slib/strcase.scm Wed Nov 18 14:15:18 1992
---- nlib/strcase.scm Tue Feb 9 00:22:03 1993
-***************
-*** 8,27 ****
- ;string-upcase!, string-downcase!, string-capitalize!
- ; are destructive versions.
-
-! (define (string-upcase! str)
- (do ((i (- (string-length str) 1) (- i 1)))
- ((< i 0) str)
- (string-set! str i (char-upcase (string-ref str i)))))
-
-! (define (string-upcase str)
- (string-upcase! (string-copy str)))
-
-! (define (string-downcase! str)
- (do ((i (- (string-length str) 1) (- i 1)))
- ((< i 0) str)
- (string-set! str i (char-downcase (string-ref str i)))))
-
-! (define (string-downcase str)
- (string-downcase! (string-copy str)))
-
- (define (string-capitalize! str) ; "hello" -> "Hello"
---- 8,30 ----
- ;string-upcase!, string-downcase!, string-capitalize!
- ; are destructive versions.
-
-! ;;; Declarations for CScheme
-! (declare (usual-integrations))
-!
-! (define-integrable (string-upcase! str)
- (do ((i (- (string-length str) 1) (- i 1)))
- ((< i 0) str)
- (string-set! str i (char-upcase (string-ref str i)))))
-
-! (define-integrable (string-upcase str)
- (string-upcase! (string-copy str)))
-
-! (define-integrable (string-downcase! str)
- (do ((i (- (string-length str) 1) (- i 1)))
- ((< i 0) str)
- (string-set! str i (char-downcase (string-ref str i)))))
-
-! (define-integrable (string-downcase str)
- (string-downcase! (string-copy str)))
-
- (define (string-capitalize! str) ; "hello" -> "Hello"
-***************
-*** 38,42 ****
- (string-set! str i (char-upcase c))))
- (set! non-first-alpha #f))))))
-
-! (define (string-capitalize str)
- (string-capitalize! (string-copy str)))
---- 41,45 ----
- (string-set! str i (char-upcase c))))
- (set! non-first-alpha #f))))))
-
-! (define-integrable (string-capitalize str)
- (string-capitalize! (string-copy str)))
-diff -c slib/synchk.scm nlib/synchk.scm
-*** slib/synchk.scm Mon Jan 27 09:28:48 1992
---- nlib/synchk.scm Tue Feb 9 00:22:03 1993
-***************
-*** 35,45 ****
- ;;; written by Alan Bawden
- ;;; modified by Chris Hanson
-
-! (define (syntax-check pattern form)
- (if (not (syntax-match? (cdr pattern) (cdr form)))
- (syntax-error "ill-formed special form" form)))
-
-! (define (ill-formed-syntax form)
- (syntax-error "ill-formed special form" form))
-
- (define (syntax-match? pattern object)
---- 35,48 ----
- ;;; written by Alan Bawden
- ;;; modified by Chris Hanson
-
-! ;;; Declarations for CScheme
-! (declare (usual-integrations))
-!
-! (define-integrable (syntax-check pattern form)
- (if (not (syntax-match? (cdr pattern) (cdr form)))
- (syntax-error "ill-formed special form" form)))
-
-! (define-integrable (ill-formed-syntax form)
- (syntax-error "ill-formed special form" form))
-
- (define (syntax-match? pattern object)
diff --git a/mitscheme.init b/mitscheme.init
index ab1e1b7..afec48e 100644
--- a/mitscheme.init
+++ b/mitscheme.init
@@ -15,8 +15,8 @@
(define (scheme-implementation-type) 'MITScheme)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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)
@@ -27,7 +27,7 @@
(define (scheme-implementation-version)
(let* ((str (with-output-to-string identify-world))
- (beg (+ (substring? "Release " str) 8))
+ (beg (+ (string-search-forward "Release " str) 8))
(rst (substring str beg (string-length str)))
(end (string-find-next-char-in-set
rst
@@ -76,36 +76,71 @@
;(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
+
+ ;; Scheme report features
+
+ rev5-report ;conforms to
+ eval ;R5RS two-argument eval
+ values ;R5RS multiple values
+ dynamic-wind ;R5RS dynamic-wind
+ macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
char-ready?
- record
- values
- dynamic-wind
- ieee-floating-point
- full-continuation
+ rationalize
+ rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
+ ;LIST->STRING, STRING-COPY,
+ ;STRING-FILL!, LIST->VECTOR,
+ ;VECTOR->LIST, and VECTOR-FILL!
+
+ rev4-report ;conforms to
+
+ ieee-p1178 ;conforms to
+
+; rev3-report ;conforms to
+
+ rev2-procedures ;SUBSTRING-MOVE-LEFT!,
+ ;SUBSTRING-MOVE-RIGHT!,
+ ;SUBSTRING-FILL!,
+ ;STRING-NULL?, APPEND!, 1+,
+ ;-1+, <?, <=?, =?, >?, >=?
+ object-hash ;has OBJECT-HASH
+
+ multiarg/and- ;/ and - can take more than 2 args.
+ with-file ;has WITH-INPUT-FROM-FILE and
+ ;WITH-OUTPUT-FROM-FILE
+ transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
+ ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
+ full-continuation ;can return multiple times
+
+ ;; Other common features
+
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
+ sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+ defmacro ;has Common Lisp DEFMACRO
+ record ;has user defined data structures
+ string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
; sort
- queue
pretty-print
object->string
+; format ;Common-lisp output formatting
trace ;has macros: TRACE and UNTRACE
- defmacro
- compiler
- getenv
+ compiler ;has (COMPILER)
+; ed ;(ED) is editor
+ system ;posix (system <string>)
+ getenv ;posix (getenv <string>)
+; program-arguments ;returns list of strings (argv)
+ current-time ;returns time in seconds since 1/1/1970
+
+ ;; Implementation Specific features
+
+ queue
Xwindows
- current-time
))
(define current-time current-file-time)
@@ -156,6 +191,13 @@
(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.
@@ -229,12 +271,14 @@
(define slib:warn
(lambda args
- (let ((port (current-error-port)))
- (display "Warn: " port)
- (for-each (lambda (x) (display x port)) 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.
diff --git a/mklibcat.scm b/mklibcat.scm
index d6bd380..5b7d211 100644
--- a/mklibcat.scm
+++ b/mklibcat.scm
@@ -1,9 +1,9 @@
;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -36,7 +36,10 @@
"schelog"))
(cons 'portable-scheme-debugger
(in-vicinity (sub-vicinity (library-vicinity) "psd")
- "psd-slib")))
+ "psd-slib"))
+ (cons 'jfilter
+ (in-vicinity (sub-vicinity (library-vicinity) "jfilter")
+ "jfilter")))
(map (lambda (p)
(if (symbol? (cdr p)) p
(cons
@@ -74,6 +77,7 @@
(topological-sort . "tsort")
(common-list-functions . "comlist")
(tree . "tree")
+ (coerce . "coerce")
(format . "format")
(generic-write . "genwrite")
(pretty-print . "pp")
@@ -104,7 +108,6 @@
(yasos macro . "yasyn")
(oop . yasos)
(collect macro . "collect")
- (struct defmacro . "struct")
(structure syntax-case . "structure")
(values . "values")
(queue . "queue")
@@ -133,6 +136,7 @@
(wt-tree . "wttree")
(string-search . "strsrch")
(root . "root")
+ (minimize . "minimize")
(precedence-parse . "prec")
(parse . precedence-parse)
(commutative-ring . "cring")
@@ -142,6 +146,17 @@
(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")
+ (diff . "differ")
+ (srfi-0 . srfi)
+ (srfi defmacro . "srfi")
+ (srfi-1 . "srfi-1")
(new-catalog . "mklibcat")
))))
(display " " op)
diff --git a/modular.scm b/modular.scm
index 357ce77..a653739 100644
--- a/modular.scm
+++ b/modular.scm
@@ -1,9 +1,9 @@
;;;; "modular.scm", modular fixnum arithmetic for Scheme
-;;; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/mulapply.scm b/mulapply.scm
index d696ee2..4f0853c 100644
--- a/mulapply.scm
+++ b/mulapply.scm
@@ -1,9 +1,9 @@
; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/mularg.scm b/mularg.scm
index a327b2b..e0ad203 100644
--- a/mularg.scm
+++ b/mularg.scm
@@ -1,5 +1,7 @@
;;; "mularg.scm" Redefine - and / to take more than 2 arguments.
+(define two-arg:/ /)
+(define two-arg:- -)
(define / /)
(define - -)
(let ((maker
diff --git a/nclients.scm b/nclients.scm
index 96c36c9..8b778b8 100644
--- a/nclients.scm
+++ b/nclients.scm
@@ -1,9 +1,9 @@
;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -226,11 +226,11 @@
;;@item
;;remote-directory
;;@end enumerate
-(define (parse-ftp-address url)
+(define (parse-ftp-address uri)
(define length? (lambda (len lst) (and (eqv? len (length lst)) lst)))
(cond
- ((not url) #f)
- ((length? 1 (scanf-read-list " ftp://%s %s" url))
+ ((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)
@@ -248,7 +248,7 @@
(list path))))))
(else
(let ((user@site #f) (colon #f) (path #f) (dross #f))
- (case (sscanf url " %[^:]%[:]%[^@] %s" user@site colon path dross)
+ (case (sscanf uri " %[^:]%[:]%[^@] %s" user@site colon path dross)
((2 3)
(let ((user #f) (site #f))
(cond ((or (eqv? 2 (sscanf user@site "/%[^@/]@%[^@]%s"
@@ -260,7 +260,7 @@
(list #f #f site path))
(else (list #f #f user@site path)))))
(else
- (let ((site (scanf-read-list " %[^@/] %s" url)))
+ (let ((site (scanf-read-list " %[^@/] %s" uri)))
(and (length? 1 site) (list #f #f (car site) #f)))))))))
;;@body
@@ -364,8 +364,8 @@
2))
;;@body
-;;Returns a URL-string for @1 on the local host.
-(define (path->url path)
+;;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)))
diff --git a/nclients.txi b/nclients.txi
index fcb77f8..ff62436 100644
--- a/nclients.txi
+++ b/nclients.txi
@@ -1,6 +1,4 @@
-
-
@defun call-with-tmpnam proc
@@ -12,14 +10,12 @@ 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
@@ -30,14 +26,12 @@ If @code{current-directory} cannot be supported by the platform, the value of @c
#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
@@ -45,24 +39,20 @@ 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
-@defun parse-ftp-address url
-
-Returns a list of the decoded FTP @var{url}; or #f if indecipherable. FTP
+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
@@ -82,7 +72,6 @@ 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
@@ -97,19 +86,18 @@ ignored; FTP takes the username and password from the @file{.netrc}
or equivalent file.
@end defun
+@defun path->uri path
-@defun path->url path
-
-Returns a URL-string for @var{path} on the local host.
+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, @code{browse-url-netscape} returns #t when the browser
-exits; otherwise it returns #f.
+argument @var{url}. If the browser starts as a background job, @code{browse-url-netscape} returns
+#t immediately; if the browser starts as a foreground job, then @code{browse-url-netscape}
+returns #t when the browser exits; otherwise it returns #f.
@end defun
diff --git a/obj2str.scm b/obj2str.scm
index a8445f6..a9b8313 100644
--- a/obj2str.scm
+++ b/obj2str.scm
@@ -1,9 +1,9 @@
;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -52,13 +52,12 @@
(generic-write obj #f #f
(lambda (str)
(let ((len (string-length str)))
- (if (> len left)
- (begin
- (set! result (cons (substring str 0 left) result))
- (set! left 0)
- #f)
- (begin
- (set! result (cons str result))
- (set! left (- left len))
- #t)))))
+ (cond ((> len left)
+ (set! result (cons (substring str 0 left) result))
+ (set! left 0)
+ #f)
+ (else
+ (set! result (cons str result))
+ (set! left (- left len))
+ #t)))))
(reverse-string-append result)))
diff --git a/obj2str.txi b/obj2str.txi
index 3ab34dc..83e8b1b 100644
--- a/obj2str.txi
+++ b/obj2str.txi
@@ -1,16 +1,8 @@
-
-
@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}.
diff --git a/object.scm b/object.scm
index c272ef9..2055224 100644
--- a/object.scm
+++ b/object.scm
@@ -1,5 +1,7 @@
;;; "object.scm" Macroless Object System
-;;;From: whumeniu@datap.ca (Wade Humeniuk)
+;;; Author: Wade Humeniuk <humeniuw@cadvision.com>
+;;;
+;;; This code is in the public domain.
;;;Date: February 15, 1994
diff --git a/paramlst.scm b/paramlst.scm
index 32fb158..fcee1c9 100644
--- a/paramlst.scm
+++ b/paramlst.scm
@@ -1,9 +1,9 @@
;;; "paramlst.scm" passing parameters by name.
-; Copyright 1995, 1996, 1997 Aubrey Jaffer
+; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -56,20 +56,19 @@
(every
(lambda (p)
(let ((good? (not (and check (not (check p))))))
- (if (not good?)
- (slib:warn
- (car parameter) 'parameter? 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)
- (and (every identity arity-specs)
- (every
- (lambda (arity-spec param)
- ((cadr arity-spec) (cdr param)))
- 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))
@@ -130,3 +129,13 @@
(set-cdr! apair (cons #t (cdr apair)))))))
apairs parameters)
parameter-list)))
+
+(define (remove-parameter pname parameter-list)
+ (define found? #f)
+ (remove-if (lambda (elt)
+ (cond ((not (and (pair? elt) (eqv? pname (car elt)))) #f)
+ (found?
+ (slib:error
+ 'remove-parameter 'multiple pname 'in parameter-list))
+ (else (set! found? #t) #t)))
+ parameter-list))
diff --git a/plottest.scm b/plottest.scm
index 20734f4..a601a49 100644
--- a/plottest.scm
+++ b/plottest.scm
@@ -1,9 +1,9 @@
;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/pnm.scm b/pnm.scm
new file mode 100644
index 0000000..c4a0e66
--- /dev/null
+++ b/pnm.scm
@@ -0,0 +1,213 @@
+;;; "pnm.scm" Read PNM image files.
+; Copyright 2000 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'scanf)
+(require 'printf)
+(require 'array)
+(require 'array-for-each)
+(require 'byte)
+(require 'line-i/o)
+
+(define (pnm:read+integer port)
+ (define uint #f)
+ (do ((chr (peek-char port) (peek-char port)))
+ ((not (and (char? chr) (or (char-whitespace? chr) (eqv? #\# chr)))))
+ (if (eqv? #\# chr)
+ (read-line port)
+ (read-char port)))
+ (if (eof-object? (peek-char port))
+ (peek-char port)
+ (and (eqv? 1 (fscanf port " %u" uint)) uint)))
+
+(define (pnm:type-dimensions port)
+ (if (input-port? port)
+ (let* ((c1 (read-char port))
+ (c2 (read-char port)))
+ (cond
+ ((and (eqv? #\P c1)
+ (char? c2)
+ (char-numeric? c2)
+ (char-whitespace? (peek-char port)))
+ (let* ((format (string->symbol (string #\p c2)))
+ (width (pnm:read+integer port))
+ (height (pnm:read+integer port))
+ (ret
+ (case format
+ ((p1) (list 'pbm width height 1))
+ ((p4) (list 'pbm-raw width height 1))
+ ((p2) (list 'pgm width height (pnm:read+integer port)))
+ ((p5) (list 'pgm-raw width height (pnm:read+integer port)))
+ ((p3) (list 'ppm width height (pnm:read+integer port)))
+ ((p6) (list 'ppm-raw width height (pnm:read+integer port)))
+ (else #f))))
+ (and (char-whitespace? (read-char port)) ret)))
+ (else #f)))
+ (call-with-input-file port pnm:type-dimensions)))
+
+(define (pnm:read-binary! array port)
+ (array-map! array (lambda () (read-byte port))))
+
+(define (pnm:image-file->array path . array)
+ (set! array (and (not (null? array)) (car array)))
+ (call-with-input-file path
+ (lambda (port)
+ (apply (lambda (type width height max-pixel)
+ (define (read-binary)
+ (pnm:read-binary! array port)
+ (if (eof-object? (peek-char port)) array
+ (slib:error type 'not 'at 'file 'end)))
+ (define (read-text)
+ (array-map! array (lambda () (pnm:read+integer port)))
+ (if (eof-object? (pnm:read+integer port)) array
+ (slib:error type 'not 'at 'file 'end)))
+ (define (read-pbm)
+ (array-map! array (lambda () (eqv? 1 (pnm:read+integer port))))
+ (if (eof-object? (pnm:read+integer port)) array
+ (slib:error type 'not 'at 'file 'end)))
+ (case type
+ ((pbm)
+ (or array
+ (set! array (make-array #t height width)))
+ (read-pbm))
+ ((pgm)
+ (or array
+ (set! array (make-array max-pixel height width)))
+ (read-text))
+ ((ppm)
+ (or array
+ (set! array (make-array max-pixel height width 3)))
+ (read-text))
+ ((pbm-raw)
+ (or array
+ (set! array (make-array #t height (quotient width 8))))
+ (read-binary))
+ ((pgm-raw)
+ (or array
+ (set! array (make-array max-pixel height width)))
+ (read-binary))
+ ((ppm-raw)
+ (or array
+ (set! array (make-array max-pixel height width 3)))
+ (read-binary))))
+ (pnm:type-dimensions port)))))
+
+(define (pnm:image-file->uniform-array path . array)
+ (fluid-let ((make-array make-uniform-array)
+ (pnm:read-binary!
+ (lambda (ra port)
+ (if (array? ra #t)
+ (error 'pnm:image-file->array
+ "pbm-raw support unimplemented")
+ (let ((bytes (apply make-uniform-array #\a
+ (array-dimensions ra))))
+ (uniform-array-read! bytes port)
+ (array-map! ra char->integer bytes))))))
+ (apply pnm:image-file->array path array)))
+
+;; ARRAY is required to be zero-based.
+(define (pnm:array-write type array maxval port)
+ (define (write-header type height width maxval)
+ (let ((magic
+ (case type
+ ((pbm) "P1")
+ ((pgm) "P2")
+ ((ppm) "P3")
+ ((pbm-raw) "P4")
+ ((pgm-raw) "P5")
+ ((ppm-raw) "P6")
+ (else (error 'pnm:array-write "bad type" type)))))
+ (fprintf port "%s\n%d %d" magic width height)
+ (if maxval (fprintf port "\n%d" maxval))))
+ (define (write-pixels type array maxval)
+ (let* ((shp (array-dimensions array))
+ (height (car shp))
+ (width (cadr shp)))
+ (case type
+ ((pbm-raw)
+ (newline port)
+ (if (array? array #t)
+ (uniform-array-write array port)
+ (error 'pnm:array-write "expected bit-array" array)))
+ ((pgm-raw ppm-raw)
+ (newline port)
+;;; (let ((bytes (apply make-uniform-array #\a shp)))
+;;; (array-map! bytes integer->char array)
+;;; (uniform-array-write bytes port))
+ (uniform-array-write array port))
+ ((pbm)
+ (do ((i 0 (+ i 1)))
+ ((>= i height))
+ (do ((j 0 (+ j 1)))
+ ((>= j width))
+ (display (if (zero? (remainder j 35)) #\newline #\space) port)
+ (display (if (array-ref array i j) #\1 #\0) port)))
+ (newline port))
+ ((pgm)
+ (do ((i 0 (+ i 1)))
+ ((>= i height))
+ (do ((j 0 (+ j 1)))
+ ((>= j width))
+ (display (if (zero? (remainder j 17)) #\newline #\space) port)
+ (display (array-ref array i j) port)))
+ (newline port))
+ ((ppm)
+ (do ((i 0 (+ i 1)))
+ ((>= i height))
+ (do ((j 0 (+ j 1)))
+ ((>= j width))
+ (display (if (zero? (remainder j 5)) #\newline " ") port)
+ (display (array-ref array i j 0) port)
+ (display #\space port)
+ (display (array-ref array i j 1) port)
+ (display #\space port)
+ (display (array-ref array i j 2) port)))
+ (newline port)))))
+
+ (if (output-port? port)
+ (let ((rnk (array-rank array))
+ (shp (array-dimensions array)))
+ (case type
+ ((pbm pbm-raw)
+ (or (and (eqv? 2 rnk)
+ (integer? (car shp))
+ (integer? (cadr shp)))
+ (error 'pnm:array-write "bad shape" type array))
+ (or (eqv? 1 maxval)
+ (error 'pnm:array-write "maxval supplied not 1" type))
+ (write-header type (car shp) (cadr shp) #f)
+ (write-pixels type array 1))
+ ((pgm pgm-raw)
+ (or (and (eqv? 2 rnk)
+ (integer? (car shp))
+ (integer? (cadr shp)))
+ (error 'pnm:array-write "bad shape" type array))
+ (write-header type (car shp) (cadr shp) maxval)
+ (write-pixels type array maxval))
+ ((ppm ppm-raw)
+ (or (and (eqv? 3 rnk)
+ (integer? (car shp))
+ (integer? (cadr shp))
+ (eqv? 3 (caddr shp)))
+ (error 'pnm:array-write "bad shape" type array))
+ (write-header type (car shp) (cadr shp) maxval)
+ (write-pixels type array maxval))
+ (else (error 'pnm:array-write type 'unrecognized 'type))))
+ (call-with-output-file port
+ (lambda (port)
+ (pnm:array-write type array maxval port)))))
diff --git a/pp.scm b/pp.scm
index 1dbada0..feb90a8 100644
--- a/pp.scm
+++ b/pp.scm
@@ -1,12 +1,15 @@
-;"pp.scm" Pretty-print
-
+;"pp.scm" Pretty-Print
(require 'generic-write)
-; (pretty-print obj port) pretty prints 'obj' on 'port'. The current
-; output port is used if 'port' is not specified.
-
(define (pp:pretty-print obj . opt)
(let ((port (if (pair? opt) (car opt) (current-output-port))))
- (generic-write obj #f 79 (lambda (s) (display s port) #t))))
+ (generic-write obj #f (output-port-width port)
+ (lambda (s) (display s port) #t))))
+
+(define (pretty-print->string obj . width)
+ (define result '())
+ (generic-write obj #f (if (null? width) (output-port-width) (car width))
+ (lambda (str) (set! result (cons str result)) #t))
+ (reverse-string-append result))
(define pretty-print pp:pretty-print)
diff --git a/ppfile.scm b/ppfile.scm
index 4b21b6e..c69390d 100644
--- a/ppfile.scm
+++ b/ppfile.scm
@@ -1,9 +1,9 @@
;;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/prec.scm b/prec.scm
index f2f7582..47807ad 100644
--- a/prec.scm
+++ b/prec.scm
@@ -1,9 +1,9 @@
; "prec.scm", dynamically extensible parser/tokenizer -*-scheme-*-
-; Copyright 1989, 1990, 1991, 1992, 1993, 1995, 1997 Aubrey Jaffer.
+; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -417,7 +417,7 @@
;;; On MS-DOS systems, <ctrl>-Z (26) needs to be ignored in order to
;;; avoid problems at end of files.
(case (software-type)
- ((MSDOS)
+ ((MS-DOS)
(if (not (char-whitespace? (integer->char 26)))
(prec:define-grammar (tok:char-group 0 (integer->char 26) #f))
)))
diff --git a/printf.scm b/printf.scm
index da7178c..d17cf79 100644
--- a/printf.scm
+++ b/printf.scm
@@ -1,9 +1,9 @@
;;;; "printf.scm" Implementation of standard C functions for Scheme
-;;; Copyright (C) 1991-1993, 1996 Aubrey Jaffer.
+;;; Copyright (C) 1991-1993, 1996, 1999-2001 Aubrey Jaffer and 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -19,117 +19,112 @@
(require 'string-case)
-;; Parse the output of NUMBER->STRING.
-;; Returns a list: (sign-character digit-string exponent-integer)
+;; Determine the case of digits > 9. We assume this to be constant.
+(define stdio:hex-upper-case? (string=? "-F" (number->string -15 16)))
+
+;; Parse the output of NUMBER->STRING and pass the results to PROC.
+;; PROC takes (SIGN-CHARACTER DIGIT-STRING EXPONENT-INTEGER . IMAGPART)
;; 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 (list? 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 (and (< i n)
- (char=? #\0 (string-ref digs i)))
- (loop (+ i 1) (- exp 1))
- (list sgn (substring digs (- i 1) n) exp)))))
- 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))))))
+;; If STR denotes a number with imaginary part not exactly zero,
+;; 3 additional elements for the imaginary part are passed.
+;; If STR cannot be parsed, return #F without calling PROC.
+(define (stdio:parse-float str proc)
+ (let ((n (string-length str)))
+ (define (parse-error) #f)
+ (define (prefix i cont)
+ (if (and (< i (- n 1))
+ (char=? #\# (string-ref str i)))
+ (case (string-ref str (+ i 1))
+ ((#\d #\i #\e) (prefix (+ i 2) cont))
+ ((#\.) (cont i))
+ (else (parse-error)))
+ (cont i)))
+ (define (sign i cont)
+ (if (< i n)
+ (let ((c (string-ref str i)))
+ (case c
+ ((#\- #\+) (cont (+ i 1) c))
+ (else (cont i #\+))))))
+ (define (digits i cont)
+ (do ((j i (+ j 1)))
+ ((or (>= j n)
+ (not (or (char-numeric? (string-ref str j))
+ (char=? #\# (string-ref str j)))))
+ (cont j (if (= i j) "0" (substring str i j))))))
+ (define (point i cont)
+ (if (and (< i n)
+ (char=? #\. (string-ref str i)))
+ (cont (+ i 1))
+ (cont i)))
+ (define (exp i cont)
+ (cond ((>= i n) (cont i 0))
+ ((memv (string-ref str i)
+ '(#\e #\s #\f #\d #\l #\E #\S #\F #\D #\L))
+ (sign (+ i 1)
+ (lambda (i sgn)
+ (digits i
+ (lambda (i digs)
+ (cont i
+ (if (char=? #\- sgn)
+ (- (string->number digs))
+ (string->number digs))))))))
+ (else (cont i 0))))
+ (define (real i cont)
+ (prefix
+ i
+ (lambda (i)
+ (sign
+ i
+ (lambda (i sgn)
+ (digits
+ i
+ (lambda (i idigs)
+ (point
+ i
+ (lambda (i)
+ (digits
+ i
+ (lambda (i fdigs)
+ (exp i
+ (lambda (i ex)
+ (let* ((digs (string-append "0" idigs fdigs))
+ (ndigs (string-length digs)))
+ (let loop ((j 1)
+ (ex (+ ex (string-length idigs))))
+ (cond ((>= j ndigs) ;; Zero
+ (cont i sgn "0" 1))
+ ((char=? #\0 (string-ref digs j))
+ (loop (+ j 1) (- ex 1)))
+ (else
+ (cont i sgn
+ (substring digs (- j 1) ndigs)
+ ex))))))))))))))))))
+ (real 0
+ (lambda (i sgn digs ex)
+ (cond
+ ((= i n) (proc sgn digs ex))
+ ((memv (string-ref str i) '(#\+ #\-))
+ (real i
+ (lambda (j im-sgn im-digs im-ex)
+ (if (and (= j (- n 1))
+ (char-ci=? #\i (string-ref str j)))
+ (proc sgn digs ex im-sgn im-digs im-ex)
+ (parse-error)))))
+ ((eqv? (string-ref str i) #\@)
+ ;; Polar form: No point in parsing the angle ourselves,
+ ;; since some transcendental approximation is unavoidable.
+ (let ((num (string->number str)))
+ (if num
+ (stdio:parse-float
+ (number->string (real-part num))
+ (lambda (sgn digs ex)
+ (stdio:parse-float
+ (number->string (imag-part num))
+ (lambda (im-sgn im-digs im-ex)
+ (proc sgn digs ex im-sgn im-digs im-ex)))))
+ (parse-error))))
+ (else #f))))))
;; STR is a digit string representing a floating point mantissa, STR must
;; begin with "0", after which a decimal point is understood.
@@ -144,13 +139,14 @@
(cond ((< ndigs 0) "")
((= n ndigs) str)
((< n ndigs)
- (let ((zeropad (make-string
- (max 0 (- (or strip-0s ndigs) n))
- (if (char-numeric? (string-ref str n))
- #\0 #\#))))
- (if (zero? (string-length zeropad))
+ (let ((padlen (max 0 (- (or strip-0s ndigs) n))))
+ (if (zero? padlen)
str
- (string-append str zeropad))))
+ (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)
@@ -162,7 +158,8 @@
(if (or (> ldig 5)
(and (= ldig 5)
(let loop ((i (+ 2 ndigs)))
- (if (> i n) (odd? (dig ndigs))
+ (if (> i n)
+ (odd? (dig ndigs))
(if (zero? (dig i))
(loop (+ i 1))
#t)))))
@@ -208,6 +205,12 @@
(slib:error 'printf "wrong number of arguments"
(length args)
format-string))
+ (define (out* strs)
+ (if (string? strs) (out strs)
+ (let out-loop ((strs strs))
+ (or (null? strs)
+ (and (out (car strs))
+ (out-loop (cdr strs)))))))
(let loop ((args args))
(advance)
@@ -252,27 +255,24 @@
(define (pad pre . strs)
(let loop ((len (string-length pre))
(ss strs))
- (cond ((>= len width) (apply string-append pre strs))
+ (cond ((>= len width) (cons pre strs))
((null? ss)
(cond (left-adjust
- (apply string-append
- pre
- (append strs
- (list (make-string
- (- width len) #\space)))))
+ (cons pre
+ (append strs
+ (list (make-string
+ (- width len) #\space)))))
(leading-0s
- (apply string-append
- pre
- (make-string (- width len) #\0)
- strs))
+ (cons pre
+ (cons (make-string (- width len) #\0)
+ strs)))
(else
- (apply string-append
- (make-string (- width len) #\space)
- pre strs))))
+ (cons (make-string (- width len) #\space)
+ (cons pre strs)))))
(else
(loop (+ len (string-length (car ss))) (cdr ss))))))
(define integer-convert
- (lambda (s radix)
+ (lambda (s radix fixcase)
(cond ((not (negative? precision))
(set! leading-0s #f)
(if (and (zero? precision)
@@ -283,6 +283,7 @@
((or (not s) (null? s)) "0")
((string? s) s)
(else "1")))
+ (if fixcase (set! s (fixcase s)))
(let ((pre (cond ((equal? "" s) "")
((eqv? #\- (string-ref s 0))
(set! s (substring s 1 (string-length s)))
@@ -380,26 +381,28 @@
(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 "???")))))
+ (else "???"))))
+ (define (format-real 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"))))
+ (or (stdio:parse-float str
+ (lambda (sgn digs expon . imag)
+ (apply pad
+ (apply format-real
+ signed
+ sgn digs expon imag))))
+ (pad "???"))))
(do ()
((case fc
((#\-) (set! left-adjust #t) #f)
@@ -432,7 +435,7 @@
(wna)))
(case fc
- ;; only - is allowed between % and c
+ ;; only - is allowed between % and c
((#\c #\C) ; C is enhancement
(and (out (string (car args))) (loop (cdr args))))
@@ -445,18 +448,20 @@
(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)))))
+ (and
+ (out* (cond
+ ((<= width (string-length s)) s)
+ (left-adjust
+ (list
+ s (make-string (- width (string-length s)) #\ )))
+ (else
+ (list
+ (make-string (- width (string-length s))
+ (if leading-0s #\0 #\ ))
+ s))))
+ (loop (cdr args)))))
- ;; SLIB extension
+ ;; SLIB extension
((#\a #\A) ;#\a #\A are pretty-print
(require 'generic-write)
(let ((os "") (pr precision))
@@ -508,22 +513,31 @@
(out os)))))
(loop (cdr args)))
((#\d #\D #\i #\I #\u #\U)
- (and (out (integer-convert (car args) 10)) (loop (cdr args))))
+ (and (out* (integer-convert (car args) 10 #f))
+ (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)))
+ (and (out* (integer-convert (car args) 8 #f))
+ (loop (cdr args))))
+ ((#\x)
+ (and (out* (integer-convert
+ (car args) 16
+ (if stdio:hex-upper-case? string-downcase #f)))
+ (loop (cdr args))))
+ ((#\X)
+ (and (out* (integer-convert
+ (car args) 16
+ (if stdio:hex-upper-case? #f string-upcase)))
(loop (cdr args))))
((#\b #\B)
- (and (out (integer-convert (car args) 2)) (loop (cdr args))))
+ (and (out* (integer-convert (car args) 2 #f))
+ (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))))
+ (and (out* (float-convert (car args) fc)) (loop (cdr args))))
(else
- (cond ((end-of-format?) (incomplete))
- (else (and (out #\%) (out fc) (out #\?) (loop args))))))))
+ (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)
diff --git a/priorque.scm b/priorque.scm
index 9002c01..0ad3007 100644
--- a/priorque.scm
+++ b/priorque.scm
@@ -1,9 +1,9 @@
;;;; "priorque.scm" priority queues for Scheme.
-;;; Copyright (C) 1992, 1993, 1994, 1995, 1997 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/process.scm b/process.scm
index 6b0acc3..bdd7969 100644
--- a/process.scm
+++ b/process.scm
@@ -1,9 +1,9 @@
;;;; "process.scm", Multi-Processing for Scheme
-;;; Copyright (C) 1992, 1993 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/pscheme.init b/pscheme.init
index dfa05a8..841f191 100644
--- a/pscheme.init
+++ b/pscheme.init
@@ -1,202 +1,256 @@
-;;; "pscheme.init" -*-scheme-*-
-;;; SLIB init file for Pocket Scheme
-;;; SLIB orig Author: Aubrey Jaffer (jaffer@ai.mit.edu)
-;;; Author: Ben Goetter <goetter@angrygraycat.com>
-;;; Initial work for 0.2.3 by Robert Goldman (goldman@htc.honeywell.com)
-;;;
-;;; This code is in the public domain.
-
-; best fit for Windows CE?
-(define (software-type) 'MS-DOS)
-
-(define (scheme-implementation-type) 'PocketScheme)
-(define (scheme-implementation-version) "0.3.6")
-
-(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 *features*
- '(source
- rev4-report
- ieee-p1178
- rev4-optional-procedures
- multiarg/and-
- multiarg-apply
- with-file
- char-ready?
- defmacro
- delay
- eval
- dynamic-wind
- full-continuation
- ;;trace ; Comment out for SLIB TRACE macros
- system
- string-port
- ))
-
-;;; (OUTPUT-PORT-WIDTH <port>)
-(define (output-port-width . arg) 79)
-
-;;; (OUTPUT-PORT-HEIGHT <port>)
-(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)
- (let ((file #f))
- (with-handlers (((lambda (x) #t) (lambda (x) #f)))
- (set! file (open-input-file f))
- (close-input-port file)
- #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.
-;;; The secondary representation extends fixnum values to 0xffffffff.
-(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 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 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 . k)
- (error
- (cond
- ((= (length k) 0) '())
- ((= (length k) 1) (car k))
- ((provided? 'string-port)
- (call-with-output-string
- (lambda (out)
- (let ((add-space #f))
- (map
- (lambda (arg)
- (if add-space (write-char #\space out) (set! add-space #t))
- (display arg out))
- k)))))
- (else (car k)))))
-
-;;; For the benefit of slib:error above, 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) ".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)
- (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)
-
-;;; Hold onto pscheme native version
-(define pscheme:require require)
-(slib:load (in-vicinity (library-vicinity) "require"))
+;;; "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 ;can load scheme source files
+ ;(slib:load-source "filename")
+; compiled ;can load compiled files
+ ;(slib:load-compiled "filename")
+
+ ;; Scheme report features
+
+; rev5-report ;conforms to
+ eval ;R5RS two-argument eval
+; values ;R5RS multiple values
+ dynamic-wind ;R5RS dynamic-wind
+; macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+ char-ready?
+ rationalize
+ rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
+ ;LIST->STRING, STRING-COPY,
+ ;STRING-FILL!, LIST->VECTOR,
+ ;VECTOR->LIST, and VECTOR-FILL!
+
+ rev4-report ;conforms to
+
+ ieee-p1178 ;conforms to
+
+; rev3-report ;conforms to
+
+; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
+ ;SUBSTRING-MOVE-RIGHT!,
+ ;SUBSTRING-FILL!,
+ ;STRING-NULL?, APPEND!, 1+,
+ ;-1+, <?, <=?, =?, >?, >=?
+; object-hash ;has OBJECT-HASH
+
+ multiarg/and- ;/ and - can take more than 2 args.
+ with-file ;has WITH-INPUT-FROM-FILE and
+ ;WITH-OUTPUT-FROM-FILE
+; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
+; ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
+ full-continuation ;can return multiple times
+
+ ;; Other common features
+
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+ defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+ string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
+; sort
+; pretty-print
+; object->string
+; format ;Common-lisp output formatting
+; Undef this to get the SLIB TRACE macros
+; 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)
+; current-time ;returns time in seconds since 1/1/1970
+
+ ;; Implementation Specific features
+
+ ))
+
+;;; (OUTPUT-PORT-WIDTH <port>)
+;;; (OUTPUT-PORT-HEIGHT <port>)
+;; $BUGBUG completely bogus values.
+(define (output-port-width . arg) 79)
+(define (output-port-height . arg) 12)
+
+;;; (TMPNAM) makes a temporary file name.
+(define tmpnam (let ((cntr 100))
+ (lambda () (set! cntr (+ 1 cntr))
+ (string-append "slib_" (number->string cntr)))))
+
+;;; (FILE-EXISTS? <string>)
+(define (file-exists? f)
+ (with-handlers (((lambda (x) #t) (lambda (x) #f)))
+ (close-input-port (open-input-file f))
+ #t))
+
+;; pscheme: current-error-port, delete-file, force-output already defined
+
+;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
+;;; be returned by CHAR->INTEGER.
+;(define char-code-limit
+; (with-handlers (
+; ((lambda (x) #t) (lambda (x) 256))
+; )
+; (integer->char 65535)
+; 65536))
+;;; Currently there are only three clients of this symbol.
+;;; Following observations relate to PScheme 0.3.5, JACAL 1a9, SLIB 2c5.
+;;; JACAL: crashes when set to 65536.
+;;; make-crc: extremely inefficient when set to 65536, spending forever in init
+;;; precedence-parse: ignores any setting in excess of 256
+;;; So we patch it to 256.
+(define char-code-limit 256)
+
+;;; MOST-POSITIVE-FIXNUM is used in modular.scm
+;;; This is the most positive immediate-value fixnum in PScheme.
+(define most-positive-fixnum #x07FFFFFF)
+
+;;; Return argument
+(define (identity x) x)
+
+;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
+(define slib:eval eval)
+
+;;; If your implementation provides R4RS macros:
+;(define macro:eval slib:eval)
+;(define macro:load load)
+
+; Define defmacro in terms of our define-macro
+(define-macro (defmacro name args . body)
+ `(define-macro (,name ,@args) ,@body))
+
+; following defns removed in 0.6.3 while I rethink macro support
+;(define defmacro? macro?)
+;(define macroexpand expand-macro)
+;(define macroexpand-1 expand-macro-1)
+
+(define gentemp gensym)
+
+(define base:eval slib:eval)
+(define defmacro:eval slib:eval)
+
+(define (slib:eval-load <pathname> evl)
+ (if (not (file-exists? <pathname>))
+ (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
+ (call-with-input-file <pathname>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <pathname>)
+ (do ((o (read port) (read port)))
+ ((eof-object? o))
+ (evl o))
+ (set! *load-pathname* old-load-pathname)))))
+
+(define (defmacro:load <pathname>)
+ (slib:eval-load <pathname> defmacro:eval))
+
+(define slib:warn
+ (lambda args
+ (let ((port (current-error-port)))
+ (display "Warn: " port)
+ (for-each (lambda (x) (display x port)) args))))
+
+;;; Define an error procedure for the library
+(define slib:error error)
+
+;;; As announced by feature string-port
+(define (call-with-output-string t)
+ (let* ((p (open-output-string))
+ (r (t p))
+ (s (get-output-string p)))
+ (close-output-port p)
+ s))
+
+(define (call-with-input-string s t)
+ (let* ((p (open-input-string s))
+ (r (t p)))
+ (close-input-port p)
+ r))
+
+;;; define these as appropriate for your system.
+(define slib:tab (integer->char 9))
+(define slib:form-feed (integer->char 12))
+
+;;; Support for older versions of Scheme. Not enough code for its own file.
+(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
+(define t #t)
+(define nil #f)
+
+;;; Define these if your implementation's syntax can support it and if
+;;; they are not already defined.
+
+(define (1+ n) (+ n 1))
+(define (-1+ n) (+ n -1))
+(define 1- -1+)
+
+;;; Define SLIB:EXIT to be the implementation procedure to exit or
+;;; return if exitting not supported.
+(define slib:exit exit)
+
+;;; Here for backward compatability
+(define scheme-file-suffix
+ (let ((suffix (case (software-type)
+ ((NOSVE) "_scm")
+ (else ".scm"))))
+ (lambda () suffix)))
+
+;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
+;;; suffix all the module files in SLIB have. See feature 'SOURCE.
+
+(define (slib:load-source f)
+ (if (not (file-exists? f))
+ (set! f (string-append f (scheme-file-suffix))))
+ (load f))
+
+;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
+;;; by compiling "foo.scm" if this implementation can compile files.
+;;; See feature 'COMPILED.
+
+(define slib:load-compiled load)
+
+;;; At this point SLIB:LOAD must be able to load SLIB files.
+
+(define slib:load slib:load-source)
+
+;;; Pscheme and SLIB both define REQUIRE, so dispatch on argument type.
+;;; The SLIB REQUIRE does accept strings, though this facility seems never to be used.
+(define pscheme:require require)
+(slib:load (in-vicinity (library-vicinity) "require"))
+(define slib:require require)
+(define (require x)
+ (if (string? x) (pscheme:require x) (slib:require x)))
diff --git a/psxtime.scm b/psxtime.scm
index 5322c44..9d94b86 100644
--- a/psxtime.scm
+++ b/psxtime.scm
@@ -1,9 +1,9 @@
;;;; "psxtime.scm" Posix time conversion routines
-;;; Copyright (C) 1994, 1997 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/qp.scm b/qp.scm
index ab6815c..08086cd 100644
--- a/qp.scm
+++ b/qp.scm
@@ -1,9 +1,9 @@
;;;; "qp.scm" Print finite length representation for any Scheme object.
-;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/r4rsyn.scm b/r4rsyn.scm
index 500d68c..12a8c41 100644
--- a/r4rsyn.scm
+++ b/r4rsyn.scm
@@ -3,8 +3,9 @@
;;;
;;; 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
+;;; Engineering and Computer Science. Permission to copy and modify
+;;; this software, to redistribute either the original software or a
+;;; modified version, and to use this software for any purpose is
;;; granted, subject to the following restrictions and understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
diff --git a/randinex.scm b/randinex.scm
index 8a0afd1..19b9d81 100644
--- a/randinex.scm
+++ b/randinex.scm
@@ -1,9 +1,9 @@
;;;"randinex.scm" Pseudo-Random inexact real numbers for scheme.
-;;; Copyright (C) 1991, 1993, 1999 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -70,6 +70,8 @@
;;; 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
@@ -82,7 +84,7 @@
(set! sum2 (+ sum2 (* x x))))))
(do ((n (- (vector-length vect) 1) (- n 2)))
((negative? n) sum2)
- (let ((t (* 6.28318530717958 (random:uniform1 state)))
+ (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)))))))))
@@ -94,10 +96,9 @@
;;@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.
+;;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)))
@@ -113,13 +114,14 @@
;;@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.
+;;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))
+ ((negative? n) r)
(vector-set! vect n (* r (vector-ref vect n))))))
diff --git a/randinex.txi b/randinex.txi
index 1d0a639..80531eb 100644
--- a/randinex.txi
+++ b/randinex.txi
@@ -1,9 +1,4 @@
-
-
-
-
-
@defun random:uniform
@@ -12,8 +7,6 @@ Returns an uniformly distributed inexact real random number in the
range between 0 and 1.
@end defun
-
-
@defun random:exp
@@ -23,8 +16,6 @@ an exponential distribution with mean @var{u} use
@w{@code{(* @var{u} (random:exp))}}.
@end defun
-
-
@defun random:normal
@@ -35,9 +26,6 @@ standard deviation @var{d} use
@w{@code{(+ @var{m} (* @var{d} (random:normal)))}}.
@end defun
-
-
-
@defun random:normal-vector! vect
@@ -46,29 +34,23 @@ 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 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.
+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 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.
+squares is less than 1.0. Thinking of @var{vect} as coordinates in
+space of dimension @var{n} = @code{(vector-length @var{vect})}, the
+coordinates are uniformly distributed within the unit @var{n}-shere.
+The sum of the squares of the numbers is returned.
@end defun
diff --git a/random.scm b/random.scm
index dc4c3fb..9f9ee98 100644
--- a/random.scm
+++ b/random.scm
@@ -1,9 +1,9 @@
;;;; "random.scm" Pseudo-Random number generator for scheme.
-;;; Copyright (C) 1991, 1993, 1998, 1999 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -84,7 +84,7 @@
;;@args
;;Returns a new copy of @code{*random-state*}.
(define (copy-random-state . sta)
- (copy-string (if (null? sta) *random-state* (car sta))))
+ (string-copy (if (null? sta) *random-state* (car sta))))
;;@body
diff --git a/random.txi b/random.txi
index f144837..d9474f9 100644
--- a/random.txi
+++ b/random.txi
@@ -1,8 +1,4 @@
-
-
-
-
@defun random n
@@ -17,10 +13,6 @@ 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
@@ -39,8 +31,6 @@ Returns a new copy of argument @var{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
@@ -52,8 +42,6 @@ Calling @code{seed->random-state} with unequal arguments will nearly
always return unequal states.
@end defun
-
-
@defun make-random-state
@@ -65,5 +53,3 @@ Scheme object; the first 50 characters of its printed representation
will be used as the seed. Otherwise the value of @code{*random-state*}
is used as the seed.
@end defun
-
-
diff --git a/ratize.scm b/ratize.scm
index d8cad11..9737934 100644
--- a/ratize.scm
+++ b/ratize.scm
@@ -1,13 +1,17 @@
-;;;; "ratize.scm" Convert number to rational number
+;;;; "ratize.scm" Find simplest number ratios
-(define (rational:simplest x y)
- (define (sr x y) (let ((fx (floor x)) (fy (floor y)))
- (cond ((not (< fx x)) fx)
- ((= fx fy) (+ fx (/ (sr (/ (- y fy)) (/ (- x fx))))))
- (else (+ 1 fx)))))
- (cond ((< y x) (rational:simplest y x))
- ((not (< x y)) (if (rational? x) x (slib:error)))
+(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) (- (sr (- y) (- x))))
- (else (if (and (exact? x) (exact? y)) 0 0.0))))
-(define (rationalize x e) (rational:simplest (- x e) (+ x e)))
+ ((negative? y) (let ((rat (sr (- y) (- x))))
+ (list (- (car rat)) (cadr rat))))
+ (else '(0 1))))
+(define (find-ratio x e) (find-ratio-between (- x e) (+ x e)))
+(define (rationalize x e) (apply / (find-ratio x e)))
diff --git a/rdms.scm b/rdms.scm
index e0dbd3c..8c8388f 100644
--- a/rdms.scm
+++ b/rdms.scm
@@ -1,9 +1,9 @@
;;; "rdms.scm" rewrite 6 - the saga continues
-; Copyright 1994, 1995, 1997 Aubrey Jaffer
+; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -77,7 +77,7 @@
(and (number? x)
(integer? x)
(not (negative? x))))
- integer
+ number
#f)
(number #f number? number #f)
(expression #f #f expression #f)
@@ -155,8 +155,8 @@
(des:getter bastab (des:keyify-1 key)))))
(define (create-database filename)
- (cond ((and filename (file-exists? filename))
- (rdms:warn 'create-database "file exists:" 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)))))
@@ -221,6 +221,9 @@
(and ans (set! rdms:filename filename))
ans))
+ (define (sync-database)
+ (sync-base lldb))
+
(define (close-database)
(close-base lldb)
(set! rdms:filename #f)
@@ -336,7 +339,9 @@
(accumulate-over-table
(lambda (operation)
(lambda mkeys (base:map-primary-key
- base-table operation (norm-mkeys mkeys)))))
+ base-table operation
+ primary-limit column-type-list
+ (norm-mkeys mkeys)))))
(norm-mkeys
(lambda (mkeys)
(define mlim (length mkeys))
@@ -345,7 +350,9 @@
((= mlim primary-limit) mkeys)
(else
(append mkeys
- (make-list (- primary-limit mlim) #f)))))))
+ (do ((k (- primary-limit mlim) (+ -1 k))
+ (result '() (cons #f result)))
+ ((<= k 0) result))))))))
(export-method
'row:retrieve
(if (= primary-limit column-limit)
@@ -366,6 +373,7 @@
(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)
@@ -458,7 +466,9 @@
(accumulate-over-table ckey:remove))
(export-method 'row:delete*
(lambda mkeys
- (base:delete* base-table (norm-mkeys 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)
@@ -505,6 +515,7 @@
(base:map-primary-key
base-table
(lambda (ckey) (key-extractor ckey))
+ primary-limit column-type-list
(norm-mkeys mkeys)))))
(else #f)))
(else
@@ -520,6 +531,7 @@
(lambda (ckey)
(list-ref (base:get base-table ckey)
index))
+ primary-limit column-type-list
(norm-mkeys mkeys))))
(else #f)))))))))))))
@@ -587,10 +599,10 @@
(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)))
+ ;;(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))
@@ -602,6 +614,7 @@
(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)
diff --git a/recobj.scm b/recobj.scm
index 36ab6d2..713f289 100644
--- a/recobj.scm
+++ b/recobj.scm
@@ -1,5 +1,7 @@
;;; "recobj.scm" Records implemented as objects.
-;;;From: whumeniu@datap.ca (Wade Humeniuk)
+;;; Author: Wade Humeniuk <humeniuw@cadvision.com>
+;;;
+;;; This code is in the public domain.
(require 'object)
(require 'common-list-functions)
diff --git a/record.scm b/record.scm
index a1a9450..9f80045 100644
--- a/record.scm
+++ b/record.scm
@@ -10,6 +10,9 @@
; prevents forgery and corruption (modification without using
; RECORD-MODIFIER) of records.
+;;2001-07-24 Aubrey Jaffer <agj@alum.mit.edu>
+;; changed identifiers containing VECTOR to VECT or VCT.
+
(require 'common-list-functions)
(define vector? vector?)
@@ -27,8 +30,8 @@
(define make-record-type #f)
(let (;; Need to close these to keep magic-cookie hidden.
- (make-vector make-vector)
- (vector vector)
+ (make-vect make-vector)
+ (vect vector)
;; We have to wrap these to keep magic-cookie hidden.
(vect? vector?)
@@ -66,7 +69,7 @@
;; 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-name (lambda (rtd) (if (vect? 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
@@ -91,13 +94,13 @@
(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)))
+ (rtd (vect magic-cookie
+ type-name
+ '()
+ field-names
+ augmented-length
+ #f
+ #f)))
(vect-set! rtd 5
(lambda (x)
(and (vect? x)
@@ -129,7 +132,7 @@
(slib:error 'record-constructor
(rtd-name rtd)
"wrong number of arguments."))
- (apply vector rtd elts)))
+ (apply vect rtd elts)))
(let ((rec-vfields (rtd-vfields rtd))
(corrected-rec-length (rtd-length rtd))
(field-names (car field-names)))
@@ -148,7 +151,7 @@
(slib:error 'record-constructor
(rtd-name rtd)
"wrong number of arguments."))
- (let ((result (make-vector corrected-rec-length)))
+ (let ((result (make-vect corrected-rec-length)))
(vect-set! result 0 rtd)
(for-each (lambda (offset elt)
(vect-set! result offset elt))
@@ -190,28 +193,26 @@
(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? (lambda (obj) (and (vect? obj) (not (rec? obj)))))
(set! vector-ref
- (lambda (vector k)
- (cond ((rec? vector)
- (vec:error 'vector-ref nvt vector))
- (else (vect-ref vector k)))))
+ (lambda (vct k)
+ (cond ((rec? vct)
+ (vec:error 'vector-ref nvt vct))
+ (else (vect-ref vct k)))))
(set! vector->list
- (lambda (vector)
- (cond ((rec? vector)
- (vec:error 'vector->list nvt vector))
- (else (vect->list vector)))))
+ (lambda (vct)
+ (cond ((rec? vct)
+ (vec:error 'vector->list nvt vct))
+ (else (vect->list vct)))))
(set! vector-set!
- (lambda (vector k obj)
- (cond ((rec? vector)
- (vec:error 'vector-set! nvt vector))
- (else (vect-set! vector k obj)))))
+ (lambda (vct k obj)
+ (cond ((rec? vct) (vec:error 'vector-set! nvt vct))
+ (else (vect-set! vct k obj)))))
(set! vector-fill!
(lambda (vector fill)
- (cond ((rec? vector)
- (vec:error 'vector-fill! nvt vector))
- (else (vect-fill! vector fill)))))
+ (cond ((rec? vct)
+ (vec:error 'vector-fill! nvt vct))
+ (else (vect-fill! vct fill)))))
(set! display
(lambda (obj . opt)
(apply disp (if (rec? obj) (rec-disp-str obj) obj) opt)))
diff --git a/repl.scm b/repl.scm
index f51f493..c647ec2 100644
--- a/repl.scm
+++ b/repl.scm
@@ -1,9 +1,9 @@
; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/report.scm b/report.scm
index 64f4d46..2c44a23 100644
--- a/report.scm
+++ b/report.scm
@@ -1,9 +1,9 @@
;;; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/require.scm b/require.scm
index a578349..e5d919d 100644
--- a/require.scm
+++ b/require.scm
@@ -1,9 +1,9 @@
;;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -17,7 +17,7 @@
;promotional, or sales literature without prior written consent in
;each case.
-(define *SLIB-VERSION* "2c7")
+(define *SLIB-VERSION* "2d2")
;;; Standardize msdos -> ms-dos.
(define software-type
@@ -48,7 +48,7 @@
((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)))
+ (slib:error 'program-vicinity " called; use slib:load to load")))
(define sub-vicinity
(case (software-type)
@@ -143,11 +143,12 @@
(define (require:provided? feature)
(if (symbol? feature)
(if (memq feature *features*) #t
- (let ((path (catalog:get feature)))
- (cond ((symbol? path) (require:provided? path))
- ((member (if (pair? path) (cdr path) path) *modules*)
- #t)
- (else #f))))
+ (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)
@@ -203,6 +204,40 @@
(let ((n (string->number "9999999999999999999999999999999")))
(if (and n (exact? n)) (require:provide 'bignum)))
+(cond
+ ((provided? 'srfi)
+ (cond-expand (srfi-0 (provide 'srfi-0)) (else #f))
+ (cond-expand (srfi-1 (provide 'srfi-1)) (else #f))
+ (cond-expand (srfi-2 (provide 'srfi-2)) (else #f))
+ (cond-expand (srfi-3 (provide 'srfi-3)) (else #f))
+ (cond-expand (srfi-4 (provide 'srfi-4)) (else #f))
+ (cond-expand (srfi-5 (provide 'srfi-5)) (else #f))
+ (cond-expand (srfi-6 (provide 'srfi-6)) (else #f))
+ (cond-expand (srfi-7 (provide 'srfi-7)) (else #f))
+ (cond-expand (srfi-8 (provide 'srfi-8)) (else #f))
+ (cond-expand (srfi-9 (provide 'srfi-9)) (else #f))
+ (cond-expand (srfi-10 (provide 'srfi-10)) (else #f))
+ (cond-expand (srfi-11 (provide 'srfi-11)) (else #f))
+ (cond-expand (srfi-12 (provide 'srfi-12)) (else #f))
+ (cond-expand (srfi-13 (provide 'srfi-13)) (else #f))
+ (cond-expand (srfi-14 (provide 'srfi-14)) (else #f))
+ (cond-expand (srfi-15 (provide 'srfi-15)) (else #f))
+ (cond-expand (srfi-16 (provide 'srfi-16)) (else #f))
+ (cond-expand (srfi-17 (provide 'srfi-17)) (else #f))
+ (cond-expand (srfi-18 (provide 'srfi-18)) (else #f))
+ (cond-expand (srfi-19 (provide 'srfi-19)) (else #f))
+ (cond-expand (srfi-20 (provide 'srfi-20)) (else #f))
+ (cond-expand (srfi-21 (provide 'srfi-21)) (else #f))
+ (cond-expand (srfi-22 (provide 'srfi-22)) (else #f))
+ (cond-expand (srfi-23 (provide 'srfi-23)) (else #f))
+ (cond-expand (srfi-24 (provide 'srfi-24)) (else #f))
+ (cond-expand (srfi-25 (provide 'srfi-25)) (else #f))
+ (cond-expand (srfi-26 (provide 'srfi-26)) (else #f))
+ (cond-expand (srfi-27 (provide 'srfi-27)) (else #f))
+ (cond-expand (srfi-28 (provide 'srfi-28)) (else #f))
+ (cond-expand (srfi-29 (provide 'srfi-29)) (else #f))
+ (cond-expand (srfi-30 (provide 'srfi-30)) (else #f))))
+
(define report:print
(lambda args
(for-each (lambda (x) (write x) (display #\ )) args)
diff --git a/root.scm b/root.scm
index d561af6..144a4af 100644
--- a/root.scm
+++ b/root.scm
@@ -1,9 +1,9 @@
;;;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/s48-0_57.init b/s48-0_57.init
new file mode 100644
index 0000000..1654cca
--- /dev/null
+++ b/s48-0_57.init
@@ -0,0 +1,381 @@
+;;;"scheme48.init" Initialisation for SLIB for Scheme48-0.57 -*-scheme-*-
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
+
+,batch on
+,load-package floatnums
+,config
+,load =scheme48/misc/packages.scm
+(define-structure slib-primitives
+ (export s48-getenv
+ s48-system
+ s48-current-error-port
+ s48-force-output
+ s48-with-handler
+ s48-ascii->char
+ s48-error)
+ (open scheme signals ascii extended-ports i/o primitives handle
+ posix c-system-function)
+ (begin
+ (define s48-getenv lookup-environment-variable)
+ (define s48-system system)
+ (define s48-current-error-port current-error-port)
+ (define s48-force-output force-output)
+ (define s48-with-handler with-handler)
+ (define s48-ascii->char ascii->char)
+ (define s48-error error)))
+,user
+,open slib-primitives
+
+(define getenv s48-getenv)
+(define system s48-system)
+
+;;; (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://s48.org/")
+
+;;; (scheme-implementation-version) should return a string describing
+;;; the version of the scheme implementation loading this file.
+
+(define scheme-implementation-version
+ (let ((version (getenv "S48_VERSION")))
+ (lambda () version)))
+
+;;; (implementation-vicinity) should be defined to be the pathname of
+;;; the directory where any auxiliary files to your Scheme
+;;; implementation reside.
+
+(define implementation-vicinity
+ (let ((vic (getenv "S48_VICINITY")))
+ (lambda () vic)))
+
+;;; (library-vicinity) should be defined to be the pathname of the
+;;; directory where files of Scheme library functions reside.
+
+(define library-vicinity
+ (let ((vic (getenv "SCHEME_LIBRARY_PATH")))
+ (lambda () vic)))
+
+;;; (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)))
+
+(let* ((siv (scheme-implementation-version))
+ (num-ver (and siv (string->number siv))))
+ (cond ((not num-ver))
+ ((>= num-ver 0.54)
+ (set! system #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")
+
+ ;; Scheme report features
+
+ rev5-report ;conforms to
+ eval ;R5RS two-argument eval
+ values ;R5RS multiple values
+ dynamic-wind ;R5RS dynamic-wind
+ macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+ char-ready?
+ rationalize
+ rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
+ ;LIST->STRING, STRING-COPY,
+ ;STRING-FILL!, LIST->VECTOR,
+ ;VECTOR->LIST, and VECTOR-FILL!
+
+ rev4-report ;conforms to
+
+ ieee-p1178 ;conforms to
+
+; rev3-report ;conforms to
+
+; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
+ ;SUBSTRING-MOVE-RIGHT!,
+ ;SUBSTRING-FILL!,
+ ;STRING-NULL?, APPEND!, 1+,
+ ;-1+, <?, <=?, =?, >?, >=?
+; object-hash ;has OBJECT-HASH
+
+; multiarg/and- ;/ and - can take more than 2 args.
+ with-file ;has WITH-INPUT-FROM-FILE and
+ ;WITH-OUTPUT-FROM-FILE
+; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
+; ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
+ full-continuation ;can return multiple times
+
+ ;; Other common features
+
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+ defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+; string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
+; sort
+; pretty-print
+; object->string
+; format ;Common-lisp output formatting
+; 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)
+; current-time ;returns time in seconds since 1/1/1970
+ ;; Implementation Specific features
+ ))
+
+;;; (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)
+ (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)))))
+
+;;; Workaround atan bug
+(define two-arg:atan atan)
+(define (atan y . x)
+ (if (null? x) (two-arg:atan y 1) (two-arg:atan y (car x))))
+
+;;; 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:load macro: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)))
+ (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)
+
+;;; Jacques Mequin wins the Spring 2001 SLIB extreme cleverness award:
+(define-syntax defmacro
+ (lambda (e r c)
+ (let* ((e-fields (cdr e))
+ (macro-name (car e-fields))
+ (macro-args (cdr e-fields))
+ (slib-store (eval 'defmacro:eval (interaction-environment))))
+ (slib-store `(defmacro ,macro-name ,@macro-args)))
+ `(define-syntax ,(cadr e)
+ (lambda (em rm cm)
+ (let ((macro-name ',(cadr e))
+ (macro-args (cdr em))
+ (slib-eval (eval 'macroexpand-1 (interaction-environment))))
+ (slib-eval `(,macro-name ,@macro-args)))))))
+
+(slib:load (in-vicinity (library-vicinity) "require"))
+
+;;; Needed to support defmacro
+(require 'defmacroexpand)
+(define *args* '())
+(define (program-arguments) (cons "scheme48" *args*))
+(set! *catalog* #f)
+
+,collect
+,batch off
+,dump slib.image "(slib 2d2)"
+,exit
diff --git a/sc2.scm b/sc2.scm
index 5a10f84..8057229 100644
--- a/sc2.scm
+++ b/sc2.scm
@@ -1,9 +1,9 @@
;"sc2.scm" Implementation of rev2 procedures eliminated in subsequent versions.
-; Copyright (C) 1991, 1993 Aubrey Jaffer.
+; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/sc4opt.scm b/sc4opt.scm
index 176d7f1..8e92237 100644
--- a/sc4opt.scm
+++ b/sc4opt.scm
@@ -1,9 +1,9 @@
;"sc4opt.scm" Implementation of optional Scheme^4 functions for IEEE Scheme
-;Copyright (C) 1991, 1993 Aubrey Jaffer.
+;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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/sc4sc3.scm b/sc4sc3.scm
index 9687856..c2d3e9a 100644
--- a/sc4sc3.scm
+++ b/sc4sc3.scm
@@ -1,9 +1,9 @@
;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/scanf.scm b/scanf.scm
index 6d3ee6e..7122d95 100644
--- a/scanf.scm
+++ b/scanf.scm
@@ -1,9 +1,9 @@
;;;;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -173,19 +173,19 @@
(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?))))
+ (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))))
diff --git a/scheme2c.init b/scheme2c.init
index 233285a..f1d9fe6 100644
--- a/scheme2c.init
+++ b/scheme2c.init
@@ -21,8 +21,8 @@
(define (scheme-implementation-type) 'Scheme->C)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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)
@@ -68,36 +68,69 @@
;(slib:load-source "filename")
; compiled ;can load compiled files
;(slib:load-compiled "filename")
- rev4-report
+
+ ;; Scheme report features
+
+; rev5-report ;conforms to
+; eval ;R5RS two-argument eval
+; values ;R5RS multiple values
+; dynamic-wind ;R5RS dynamic-wind
+; macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+ char-ready?
+ rationalize
+ rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
+ ;LIST->STRING, STRING-COPY,
+ ;STRING-FILL!, LIST->VECTOR,
+ ;VECTOR->LIST, and VECTOR-FILL!
+
+ rev4-report ;conforms to
;; 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
+
+ rev3-report ;conforms to
+
+; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
+ ;SUBSTRING-MOVE-RIGHT!,
+ ;SUBSTRING-FILL!,
+ ;STRING-NULL?, APPEND!, 1+,
+ ;-1+, <?, <=?, =?, >?, >=?
+ object-hash ;has OBJECT-HASH
+
+ multiarg/and- ;/ and - can take more than 2 args.
+ with-file ;has WITH-INPUT-FROM-FILE and
+ ;WITH-OUTPUT-FROM-FILE
+ transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
+ ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
+ full-continuation ;can return multiple times
+
+ ;; Other common features
+
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+; defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+ string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
+; sort
pretty-print
- format
+; object->string
+ format ;Common-lisp output formatting
trace ;has macros: TRACE and UNTRACE
- string-port
- system
- ;; next two could be added easily to the interpreter
-; getenv
-; program-arguments
+; compiler ;has (COMPILER)
+; ed ;(ED) is editor
+ system ;posix (system <string>)
+; getenv ;posix (getenv <string>)
+; program-arguments ;returns list of strings (argv)
+; current-time ;returns time in seconds since 1/1/1970
))
(define pretty-print pp)
@@ -151,6 +184,13 @@
(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)
@@ -167,7 +207,7 @@
(define-macro defmacro
(lambda (f e)
(let ((key (cadr f)) (pattern (caddr f)) (body (cdddr f)))
- (e `(define-macro ,key
+ (e `(define-macro ,key
(let ((%transformer (lambda ,pattern ,@body)))
(lambda (%form %expr)
(%expr (apply %transformer (cdr %form)) %expr))))
@@ -211,12 +251,14 @@
(define slib:warn
(lambda args
- (let ((port (current-error-port)))
- (display "Warn: " port)
- (for-each (lambda (x) (display x port)) 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
@@ -238,12 +280,12 @@
(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))
@@ -252,7 +294,7 @@
(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.
)))
diff --git a/scheme48.init b/scheme48.init
index 8258d97..75ab0f5 100644
--- a/scheme48.init
+++ b/scheme48.init
@@ -3,10 +3,38 @@
;;;
;;; 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
+,batch on
+,load-package floatnums
+,config
+,load =scheme48/misc/packages.scm
+(define-structure slib-primitives
+ (export s48-getenv
+ s48-system
+ s48-current-error-port
+ s48-force-output
+ s48-with-handler
+ s48-ascii->char
+ s48-error)
+ (open scheme signals ascii extended-ports i/o primitives handle
+ unix-getenv ;Comment out for versions >= 0.54
+;;; posix ;Comment out for versions < 0.54
+ )
+ (begin
+ (define s48-getenv
+ getenv ;Comment out for versions >= 0.54
+;;; lookup-environment-variable ;Comment out for versions < 0.54
+ )
+ (define s48-system (lambda (c) (vm-extension 96 c)))
+ (define s48-current-error-port current-error-port)
+ (define s48-force-output force-output)
+ (define s48-with-handler with-handler)
+ (define s48-ascii->char ascii->char)
+ (define s48-error error)))
+,user
+,open slib-primitives
+
+(define getenv s48-getenv)
+(define system s48-system)
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
@@ -18,38 +46,33 @@
(define (scheme-implementation-type) 'Scheme48)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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")
+(define (scheme-implementation-home-page) "http://s48.org/")
;;; (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"))))
+ (let ((version (getenv "S48_VERSION")))
+ (lambda () version)))
;;; (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 ]
+(define implementation-vicinity
+ (let ((vic (getenv "S48_VICINITY")))
+ (lambda () vic)))
;;; (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)
+(define library-vicinity
+ (let ((vic (getenv "SCHEME_LIBRARY_PATH")))
+ (lambda () vic)))
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
@@ -59,6 +82,12 @@
(let ((home-path (getenv "HOME")))
(lambda () home-path)))
+(let* ((siv (scheme-implementation-version))
+ (num-ver (and siv (string->number siv))))
+ (cond ((not num-ver))
+ ((>= num-ver 0.54)
+ (set! system #f))))
+
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. See Template.scm for the list of feature
;;; names.
@@ -69,24 +98,71 @@
;(slib:load-source "filename")
; compiled ;can load compiled files
;(slib:load-compiled "filename")
+
+ ;; Scheme report features
+
+ rev5-report ;conforms to
+ eval ;R5RS two-argument eval
+ values ;R5RS multiple values
+ dynamic-wind ;R5RS dynamic-wind
+ macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+ char-ready?
+ rationalize
+ rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
+ ;LIST->STRING, STRING-COPY,
+ ;STRING-FILL!, LIST->VECTOR,
+ ;VECTOR->LIST, and VECTOR-FILL!
+
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
+
+; rev3-report ;conforms to
+
+; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
+ ;SUBSTRING-MOVE-RIGHT!,
+ ;SUBSTRING-FILL!,
+ ;STRING-NULL?, APPEND!, 1+,
+ ;-1+, <?, <=?, =?, >?, >=?
+; object-hash ;has OBJECT-HASH
+
+; multiarg/and- ;/ and - can take more than 2 args.
+ with-file ;has WITH-INPUT-FROM-FILE and
+ ;WITH-OUTPUT-FROM-FILE
+; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
+; ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
full-continuation ;can return multiple times
- macro ;R4RS appendix's DEFINE-SYNTAX
- system ;posix (system <string>)
+
+ ;; Other common features
+
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+ defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+; string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
+; sort
+; pretty-print
+; object->string
+; format ;Common-lisp output formatting
+; trace ;has macros: TRACE and UNTRACE
+; compiler ;has (COMPILER)
+; ed ;(ED) is editor
getenv ;posix (getenv <string>)
+; program-arguments ;returns list of strings (argv)
+; current-time ;returns time in seconds since 1/1/1970
+ ;; Implementation Specific features
))
+(if system ;posix (system <string>)
+ (set! *features* (cons 'system *features*)))
+
;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)
@@ -124,6 +200,13 @@
(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)
@@ -140,6 +223,11 @@
(let ((ans (modulo n1 n2)))
(if (= ans n2) (- ans ans) ans)))))
+;;; Workaround atan bug
+(define two-arg:atan atan)
+(define (atan y . x)
+ (if (null? x) (two-arg:atan y 1) (two-arg:atan y (car x))))
+
;;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum #x1FFFFFFF)
@@ -164,22 +252,24 @@
(list (cons 'defmacro
(lambda (name parms . body)
`(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
- *defmacros*))))))
+ *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)))
+ (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)))
+ (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
@@ -191,11 +281,8 @@
(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 defmacro:load macro:load)
(define (slib:eval-load <pathname> evl)
(if (not (file-exists? <pathname>))
@@ -211,12 +298,15 @@
(define slib:warn
(lambda args
- (let ((port (current-error-port)))
- (display "Warn: " port)
- (for-each (lambda (x) (display x port)) 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 s48-error)
+(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))
@@ -269,4 +359,30 @@
(define transcript-on #f)
(define transcript-off #f)
+;;; Jacques Mequin wins the Spring 2001 SLIB extreme cleverness award:
+(define-syntax defmacro
+ (lambda (e r c)
+ (let* ((e-fields (cdr e))
+ (macro-name (car e-fields))
+ (macro-args (cdr e-fields))
+ (slib-store (eval 'defmacro:eval (interaction-environment))))
+ (slib-store `(defmacro ,macro-name ,@macro-args)))
+ `(define-syntax ,(cadr e)
+ (lambda (em rm cm)
+ (let ((macro-name ',(cadr e))
+ (macro-args (cdr em))
+ (slib-eval (eval 'macroexpand-1 (interaction-environment))))
+ (slib-eval `(,macro-name ,@macro-args)))))))
+
(slib:load (in-vicinity (library-vicinity) "require"))
+
+;;; Needed to support defmacro
+(require 'defmacroexpand)
+(define *args* '())
+(define (program-arguments) (cons "scheme48" *args*))
+(set! *catalog* #f)
+
+,collect
+,batch off
+,dump slib.image "(slib 2d2)"
+,exit
diff --git a/schmooz.scm b/schmooz.scm
index a09f3df..e9950d2 100644
--- a/schmooz.scm
+++ b/schmooz.scm
@@ -1,9 +1,9 @@
;;; "schmooz.scm" Program for extracting texinfo comments from Scheme.
-;;; Copyright (C) 1998 Radey Shouman and Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -17,9 +17,6 @@
;promotional, or sales literature without prior written consent in
;each case.
-;;$Header: /usr/local/cvsroot/slib/schmooz.scm,v 1.12 1999/10/11 03:36:29 jaffer Exp $
-;;$Name: $
-
;;; REPORT an error or warning
(define report
(lambda args
@@ -365,21 +362,25 @@
(define (schmooz-scm-file file txi-name)
(display "Schmoozing ") (write file)
(display " -> ") (write txi-name) (newline)
- (fluid-let ((*scheme-source* (open-file file "r"))
+ (fluid-let ((*scheme-source* (open-input-file file))
(*scheme-source-name* file)
- (*derived-txi* (open-file txi-name "w"))
+ (*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 ((scheme-file? file)
- (schmooz-scm-file
- file (scm->txi file)))
- ((texi-file? file) (schmooz-texi-file 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.
@@ -407,6 +408,20 @@
(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)
@@ -415,13 +430,19 @@
((eqv? c #\newline)
(read-char *scheme-source*)
(set! *output-line* (+ 1 *output-line*))
- (newline *derived-txi*)
+ ;;(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))))
@@ -450,7 +471,6 @@
(define (out-cmt line)
(let ((subl (substitute-macs line '())))
- (newline *derived-txi*)
(display (car subl) *derived-txi*)
(for-each
(lambda (l)
@@ -459,7 +479,8 @@
(out-cindex (cadr l)))
(else
(report "bad macro" line))))
- (cdr subl))))
+ (cdr subl))
+ (newline *derived-txi*)))
;;Comments not transcribed to generated Texinfo files.
(define (c-cmt c)
@@ -492,7 +513,7 @@
(doc-cmt (peek-char *scheme-source*))))))
;; Transcribe the comment line to C source file.
(else
- (read-line *scheme-source*) ;(out-c-cmt )
+ (read-line *scheme-source*)
(lp (peek-char *scheme-source*)))))
;;Comments incorporated in generated Texinfo files.
@@ -520,7 +541,6 @@
(cond ((eof-object? c) (lp c))
((eqv? #\; c)
(out-cmt (read-cmt-line))
- ;;(out-c-cmt (car ls))
(doc-cmt (peek-char *scheme-source*)))
((eqv? c #\newline)
(read-char *scheme-source*)
diff --git a/schmooz.texi b/schmooz.texi
new file mode 100644
index 0000000..24c30d0
--- /dev/null
+++ b/schmooz.texi
@@ -0,0 +1,104 @@
+
+@cindex schmooz
+@dfn{Schmooz} is a simple, lightweight markup language for interspersing
+Texinfo documentation with Scheme source code. Schmooz does not create
+the top level Texinfo file; it creates @samp{txi} files which can be
+imported into the documentation using the Texinfo command
+@samp{@@include}.
+
+@ftindex schmooz
+@code{(require 'schmooz)} defines the function @code{schmooz}, which is
+used to process files. Files containing schmooz documentation should
+not contain @code{(require 'schmooz)}.
+
+@deffn Procedure schmooz filename@r{scm} @dots{}
+@var{Filename}scm should be a string ending with @samp{scm} naming an
+existing file containing Scheme source code. @code{schmooz} extracts
+top-level comments containing schmooz commands from @var{filename}scm
+and writes the converted Texinfo source to a file named
+@var{filename}txi.
+
+@deffnx Procedure schmooz filename@r{texi} @dots{}
+@deffnx Procedure schmooz filename@r{tex} @dots{}
+@deffnx Procedure schmooz filename@r{txi} @dots{}
+@var{Filename} should be a string naming an existing file containing
+Texinfo source code. For every occurrence of the string @samp{@@include
+@var{filename}txi} within that file, @code{schmooz} calls itself with
+the argument @samp{@var{filename}scm}.
+@end deffn
+
+Schmooz comments are distinguished (from non-schmooz comments) by their
+first line, which must start with an at-sign (@@) preceded by one or
+more semicolons (@t{;}). A schmooz comment ends at the first subsequent
+line which does @emph{not} start with a semicolon. Currently schmooz
+comments are recognized only at top level.
+
+Schmooz comments are copied to the Texinfo output file with the leading
+contiguous semicolons removed. Certain character sequences starting
+with at-sign are treated specially. Others are copied unchanged.
+
+A schmooz comment starting with @samp{@@body} must be followed by a
+Scheme definition. All comments between the @samp{@@body} line and
+the definition will be included in a Texinfo definition, either
+a @samp{@@defun} or a @samp{@@defvar}, depending on whether a procedure
+or a variable is being defined.
+
+Within the text of that schmooz comment, at-sign
+followed by @samp{0} will be replaced by @code{@@code@{procedure-name@}}
+if the following definition is of a procedure; or
+@code{@@var@{variable@}} if defining a variable.
+
+An at-sign followed by a non-zero digit will expand to the variable
+citation of that numbered argument: @samp{@@var@{argument-name@}}.
+
+If more than one definition follows a @samp{@@body} comment line
+without an intervening blank or comment line, then those definitions
+will be included in the same Texinfo definition using @samp{@@defvarx}
+or @samp{@@defunx}, depending on whether the first definition is of
+a variable or of a procedure.
+
+Schmooz can figure out whether a definition is of a procedure if
+it is of the form:
+
+@samp{(define (<identifier> <arg> ...) <expression>)}
+
+@noindent
+or if the left hand side of the definition is some form ending in
+a lambda expression. Obviously, it can be fooled. In order to
+force recognition of a procedure definition, start the documentation
+with @samp{@@args} instead of @samp{@@body}. @samp{@@args} should
+be followed by the argument list of the function being defined,
+which may be enclosed in parentheses and delimited by whitespace,
+(as in Scheme), enclosed in braces and separated by commas, (as
+in Texinfo), or consist of the remainder of the line, separated
+by whitespace.
+
+For example:
+
+@example
+;;@@args arg1 args ...
+;;@@0 takes argument @@1 and any number of @@2
+(define myfun (some-function-returning-magic))
+@end example
+
+Will result in:
+
+@example
+@@defun myfun arg1 args @@dots@{@}
+
+@@code@{myfun@} takes argument @@var@{arg1@} and any number of @@var@{args@}
+@@end defun
+@end example
+
+@samp{@@args} may also be useful for indicating optional arguments
+by name. If @samp{@@args} occurs inside a schmooz comment section,
+rather than at the beginning, then it will generate a @samp{@@defunx}
+line with the arguments supplied.
+
+
+If the first at-sign in a schmooz comment is immediately followed by
+whitespace, then the comment will be expanded to whatever follows that
+whitespace. If the at-sign is followed by a non-whitespace character
+then the at-sign will be included as the first character of the expansion.
+This feature is intended to make it easy to include Texinfo directives
+in schmooz comments.
diff --git a/scmacro.scm b/scmacro.scm
index 47bafca..97bb52f 100644
--- a/scmacro.scm
+++ b/scmacro.scm
@@ -1,9 +1,9 @@
;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/scmactst.scm b/scmactst.scm
deleted file mode 100644
index 3b71341..0000000
--- a/scmactst.scm
+++ /dev/null
@@ -1,160 +0,0 @@
-;;;"scmactst.scm" test syntactic closures macros
-;;; From "sc-macro.doc", A Syntactic Closures Macro Facility by Chris Hanson
-
-(define errs '())
-(define test
- (lambda (expect fun . args)
- (write (cons fun args))
- (display " ==> ")
- ((lambda (res)
- (write res)
- (newline)
- (cond ((not (equal? expect res))
- (set! errs (cons (list res expect (cons fun args)) errs))
- (display " BUT EXPECTED ")
- (write expect)
- (newline)
- #f)
- (else #t)))
- (if (procedure? fun) (apply fun args) (car args)))))
-
-(require 'syntactic-closures)
-
-(macro:expand
- '(define-syntax push
- (syntax-rules ()
- ((push item list)
- (set! list (cons item list))))))
-
-(test '(set! foo (cons bar foo)) 'push (macro:expand '(push bar foo)))
-
-(macro:expand
- '(define-syntax push1
- (transformer
- (lambda (exp env)
- (let ((item
- (make-syntactic-closure env '() (cadr exp)))
- (list
- (make-syntactic-closure env '() (caddr exp))))
- `(set! ,list (cons ,item ,list)))))))
-
-(test '(set! foo (cons bar foo)) 'push1 (macro:expand '(push1 bar foo)))
-
-(macro:expand
- '(define-syntax loop
- (transformer
- (lambda (exp env)
- (let ((body (cdr exp)))
- `(call-with-current-continuation
- (lambda (exit)
- (let f ()
- ,@(map (lambda (exp)
- (make-syntactic-closure env '(exit)
- exp))
- body)
- (f)))))))))
-
-(macro:expand
- '(define-syntax let1
- (transformer
- (lambda (exp env)
- (let ((id (cadr exp))
- (init (caddr exp))
- (exp (cadddr exp)))
- `((lambda (,id)
- ,(make-syntactic-closure env (list id) exp))
- ,(make-syntactic-closure env '() init)))))))
-
-(test 93 'let1 (macro:eval '(let1 a 90 (+ a 3))))
-
-(macro:expand
- '(define-syntax loop-until
- (syntax-rules
- ()
- ((loop-until id init test return step)
- (letrec ((loop
- (lambda (id)
- (if test return (loop step)))))
- (loop init))))))
-
-(test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33)))))
- (loop 3)))
- 'loop
- (macro:expand '(loop-until foo 3 #t 12 33)))
-
-(macro:expand
- '(define-syntax loop-until1
- (transformer
- (lambda (exp env)
- (let ((id (cadr exp))
- (init (caddr exp))
- (test (cadddr exp))
- (return (cadddr (cdr exp)))
- (step (cadddr (cddr exp)))
- (close
- (lambda (exp free)
- (make-syntactic-closure env free exp))))
- `(letrec ((loop
- ,(capture-syntactic-environment
- (lambda (env)
- `(lambda (,id)
- (,(make-syntactic-closure env '() `if)
- ,(close test (list id))
- ,(close return (list id))
- (,(make-syntactic-closure env '()
- `loop)
- ,(close step (list id)))))))))
- (loop ,(close init '()))))))))
-
-(test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33)))))
- (loop 3)))
- 'loop1
- (macro:expand '(loop-until1 foo 3 #t 12 33)))
-
-(test '#t 'identifier (identifier? 'a))
-;;; this needs to setup ENV.
-;;;(test '#t 'identifier
-;;; (identifier? (macro:expand (make-syntactic-closure env '() 'a))))
-(test #f 'identifier (identifier? "a"))
-(test #f 'identifier (identifier? #\a))
-(test #f 'identifier (identifier? 97))
-(test #f 'identifier (identifier? #f))
-(test #f 'identifier (identifier? '(a)))
-(test #f 'identifier (identifier? '#(a)))
-
-(test '(#t #f)
- 'syntax
- (macro:eval
- '(let-syntax
- ((foo
- (transformer
- (lambda (form env)
- (capture-syntactic-environment
- (lambda (transformer-env)
- (identifier=? transformer-env 'x env 'x)))))))
- (list (foo)
- (let ((x 3))
- (foo))))))
-
-
-(test '(#f #t)
- 'syntax
- (macro:eval
- '(let-syntax ((bar foo))
- (let-syntax
- ((foo
- (transformer
- (lambda (form env)
- (capture-syntactic-environment
- (lambda (transformer-env)
- (identifier=? transformer-env 'foo
- env (cadr form))))))))
- (list (foo foo)
- (foo bar))))))
-
-(newline)
-(cond ((null? errs) (display "Passed all tests"))
- (else (display "errors were:") (newline)
- (display "(got expected (call))") (newline)
- (for-each (lambda (l) (write l) (newline)) errs)))
-(newline)
diff --git a/scsh.init b/scsh.init
index 04d4818..35e8c6f 100644
--- a/scsh.init
+++ b/scsh.init
@@ -13,12 +13,12 @@
(define (scheme-implementation-type) 'Scsh)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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/scsh/")
+ "http://swissnet.ai.mit.edu/ftpdir/scsh/")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
@@ -58,6 +58,7 @@
rev4-report ;conforms to
; rev3-report ;conforms to
ieee-p1178 ;conforms to
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
; sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
@@ -91,7 +92,6 @@
; object-hash ;has OBJECT-HASH
; sort
-; queue ;queues
; pretty-print
; object->string
format
@@ -101,10 +101,6 @@
; 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
))
@@ -134,6 +130,13 @@
;;; 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)
@@ -206,12 +209,15 @@
(define slib:warn
(lambda args
- (let ((port (current-error-port)))
- (display "Warn: " port)
- (for-each (lambda (x) (display x port)) 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 error)
+(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))
diff --git a/simetrix.scm b/simetrix.scm
new file mode 100644
index 0000000..3a3f16b
--- /dev/null
+++ b/simetrix.scm
@@ -0,0 +1,246 @@
+;;;; "simetrix.scm" SI Metric Interchange Format for Scheme
+;;; Copyright (C) 2000, 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;; Implements "Representation of numerical values and SI units in
+;; character strings for information interchanges"
+;; http://swissnet.ai.mit.edu/~jaffer/MIXF.html
+
+(require 'precedence-parse)
+
+;;; Combine alists
+(define (SI:adjoin unitlst SIms)
+ (for-each (lambda (new)
+ (define pair (assoc (car new) SIms))
+ (if pair
+ (set-cdr! pair (+ (cdr new) (cdr pair)))
+ (set! SIms (cons (cons (car new) (cdr new)) SIms))))
+ unitlst)
+ SIms)
+
+;;; Combine unit-alists
+(define (SI:product unit1 unit2)
+ (define nunits '())
+ (set! unit1 (SI:expand-unit unit1))
+ (set! unit2 (SI:expand-unit unit2))
+ (cond ((and unit1 unit2)
+ (set! nunits (SI:adjoin unit1 nunits))
+ (set! nunits (SI:adjoin unit2 nunits))
+ nunits)
+ (else #f)))
+
+(define (SI:quotient unit1 . units)
+ (apply SI:product unit1
+ (map (lambda (unit) (SI:pow unit -1)) units)))
+
+(define (SI:pow unit expon)
+ (define punit (SI:expand-unit unit))
+ (and punit (number? expon)
+ (map (lambda (unit-pair)
+ (cons (car unit-pair) (* (cdr unit-pair) expon)))
+ punit)))
+
+;;; Parse helper functions.
+(define (SI:solidus . args)
+ (if (and (= 2 (length args))
+ (number? (car args))
+ (number? (cadr args)))
+ (/ (car args) (cadr args))
+ (apply SI:quotient args)))
+
+(define (SI:e arg1 arg2)
+ (cond ((and (number? arg1) (number? arg2)
+ (exact? arg2))
+ (let ((expo (string->number
+ (string-append "1e" (number->string arg2)))))
+ (and expo (* arg1 expo))))
+ (else (SI:product arg1 arg2))))
+
+(define (SI:dot arg1 arg2)
+ (cond ((and (number? arg1) (number? arg2)
+ (exact? arg1) (exact? arg2)
+ (positive? arg2))
+ (string->number
+ (string-append (number->string arg1) "." (number->string arg2))))
+ (else (SI:product arg1 arg2))))
+
+(define (SI:minus arg) (and (number? arg) (- arg)))
+
+(define (SI:identity . args) (and (= 1 (length args)) (car args)))
+
+;;; Binary prefixes are (zero? (modulo expo 10))
+(define SI:prefix-exponents
+ '(("Y" 24) ("Z" 21) ("E" 18) ("P" 15)
+ ("T" 12) ("G" 9) ("M" 6) ("k" 3) ("h" 2) ("da" 1)
+ ("d" -1) ("c" -2) ("m" -3) ("u" -6) ("n" -9)
+ ("p" -12) ("f" -15) ("a" -18) ("z" -21) ("y" -24)
+
+ ("Ei" 60) ("Pi" 50) ("Ti" 40) ("Gi" 30) ("Mi" 20) ("Ki" 10)
+ ))
+
+(define SI:unit-infos
+ `(
+ ("s" all #f)
+ ("min" none "60.s")
+ ("h" none "3600.s")
+ ("d" none "86400.s")
+ ("Hz" all "s^-1")
+ ("Bd" pos "s^-1")
+ ("m" all #f)
+ ("L" neg "dm^3")
+ ("rad" neg #f)
+ ("sr" neg "rad^2")
+ ("r" pos ,(string-append (number->string (* 8 (atan 1))) ".rad"))
+ ("o" neg ,(string-append (number->string (/ 360)) ".r"))
+ ("bit" bin #f)
+ ("B" pin "8.b")
+ ("g" all #f)
+ ("t" pos "Mg")
+ ("u" none "1.66053873e-27.kg")
+ ("mol" all #f)
+ ("kat" all "mol/s")
+ ("K" all #f)
+ ("oC" neg #f)
+ ("cd" all #f)
+ ("lm" all "cd.sr")
+ ("lx" all "lm/m^2")
+ ("N" all "m.kg/s^2")
+ ("Pa" all "N/m^2")
+ ("J" all "N.m")
+ ("eV" all "1.602176462e-19.J")
+ ("W" all "J/s")
+ ("Np" neg #f)
+ ("dB" none ,(string-append (number->string (/ (log 10) 20)) ".Np"))
+ ("A" all #f)
+ ("C" all "A.s")
+ ("V" all "W/A")
+ ("F" all "C/V")
+ ("Ohm" all "V/A")
+ ("S" all "A/V")
+ ("Wb" all "V.s")
+ ("T" all "Wb/m^2")
+ ("H" all "Wb/A")
+ ("Bq" all "s^-1")
+ ("Gy" all "m^2.s^-2")
+ ("Sv" all "m^2.s^-2")
+ ))
+
+(define (SI:try-split preSI SIm)
+ (define expo (assoc preSI SI:prefix-exponents))
+ (define stuff (assoc SIm SI:unit-infos))
+ (if expo (set! expo (cadr expo)))
+ (if stuff (set! stuff (cdr stuff)))
+ (and expo stuff
+ (let ((equivalence (cadr stuff)))
+ (and (case (car stuff) ;restriction
+ ((all) (not (zero? (modulo expo 10))))
+ ((pos) (and (positive? expo) (not (zero? (modulo expo 10)))))
+ ((bin) #t)
+ ((pin) (positive? expo))
+ ((neg) (and (negative? expo) (not (zero? (modulo expo 10)))))
+ ((none) #f)
+ (else #f))
+ (if (and (positive? expo) (zero? (modulo expo 10)))
+ (if equivalence
+ (let ((eqv (SI:expand-equivalence equivalence)))
+ (and eqv
+ (SI:adjoin (list (cons 1024 (quotient expo 10)))
+ eqv)))
+ (list (cons 1024 (quotient expo 10))
+ (cons SIm 1)))
+ (if equivalence
+ (let ((eqv (SI:expand-equivalence equivalence)))
+ (and eqv (SI:adjoin (list (cons 10 expo)) eqv)))
+ (list (cons 10 expo) (cons SIm 1))))))))
+
+(define (SI:try-simple SIm)
+ (define stuff (assoc SIm SI:unit-infos))
+ (if stuff (set! stuff (cdr stuff)))
+ (and stuff (if (cadr stuff)
+ (SI:expand-equivalence (cadr stuff))
+ (list (cons SIm 1)))))
+
+(define (SI:expand-unit str)
+ (if (symbol? str) (set! str (symbol->string str)))
+ (cond
+ ((pair? str) str)
+ ((number? str) (list (cons str 1)))
+ ((string? str)
+ (let ((len (string-length str)))
+ (let ((s1 (and (> len 1)
+ (SI:try-split (substring str 0 1) (substring str 1 len))))
+ (s2 (and (> len 2)
+ (SI:try-split (substring str 0 2) (substring str 2 len))))
+ (sn (and (SI:try-simple str))))
+ (define cnt (+ (if s1 1 0) (if s2 1 0) (if sn 1 0)))
+ (if (> cnt 1) (slib:warn 'ambiguous s1 s2 sn))
+ (or s1 s2 sn))))
+ (else #f)))
+
+(define (SI:expand-equivalence str)
+ (call-with-input-string
+ str (lambda (sport)
+ (define result (prec:parse SI:grammar 'EOS sport))
+ (cond ((eof-object? result) (list (cons 1 0)))
+ ((symbol? result) (SI:expand-unit result))
+ (else result)))))
+
+;;;; advertised interface
+(define (SI:conversion-factor to-unit from-unit)
+ (let ((funit (SI:expand-equivalence from-unit))
+ (tunit (SI:expand-equivalence to-unit)))
+ (if (and funit tunit)
+ (let loop ((unit-pairs (SI:quotient funit tunit))
+ (flactor 1))
+ (cond ((null? unit-pairs) flactor)
+ ((zero? (round (* 2 (cdar unit-pairs))))
+ (loop (cdr unit-pairs) flactor))
+ ((number? (caar unit-pairs))
+ (loop (cdr unit-pairs)
+ ((if (negative? (cdar unit-pairs)) / *)
+ flactor
+ (expt (caar unit-pairs)
+ (abs (cdar unit-pairs))))))
+ (else 0)))
+ (+ (if tunit 0 -1) (if funit 0 -2)))))
+
+(define SI:grammar #f)
+
+;;;; The parse tables.
+;;; Definitions accumulate in top-level variable *SYN-DEFS*.
+;;(trace-all (in-vicinity (program-vicinity) "simetrix.scm"))
+
+;;; Character classes
+(prec:define-grammar (tok:char-group 70 #\^ list->string))
+(prec:define-grammar (tok:char-group 49 #\. list->string))
+(prec:define-grammar (tok:char-group 50 #\/ list->string))
+(prec:define-grammar (tok:char-group 51 #\- list->string))
+(prec:define-grammar (tok:char-group 40 tok:decimal-digits
+ (lambda (l) (string->number (list->string l)))))
+(prec:define-grammar (tok:char-group 44
+ (string-append tok:upper-case tok:lower-case "@_")
+ list->string))
+
+(prec:define-grammar (prec:prefix '- SI:minus 130))
+(prec:define-grammar (prec:infix "." SI:dot 120 120))
+(prec:define-grammar (prec:infix '("e" "E") SI:e 115 125))
+(prec:define-grammar (prec:infix '/ SI:solidus 100 150))
+(prec:define-grammar (prec:infix '^ SI:pow 160 140))
+(prec:define-grammar (prec:matchfix #\( SI:identity #f #\)))
+
+(set! SI:grammar *syn-defs*)
diff --git a/slib.info b/slib.info
index 8e62273..420aa7c 100644
--- a/slib.info
+++ b/slib.info
@@ -1,5 +1,4 @@
-This is Info file slib.info, produced by Makeinfo version 1.68 from the
-input file slib.texi.
+This is slib.info, produced by makeinfo version 4.0 from slib.texi.
INFO-DIR-SECTION The Algorithmic Language Scheme
START-INFO-DIR-ENTRY
@@ -9,7 +8,8 @@ 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 Aubrey Jaffer |
+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
@@ -28,12 +28,12 @@ translation approved by the author.

File: slib.info, Node: Top, Next: The Library System, Prev: (dir), Up: (dir)
-"SLIB" is a portable library for the programming language "Scheme". It |
-provides a platform independent framework for using "packages" of |
+"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. |
+packages for all Scheme implementations. Its catalog can be
+transparently extended to accomodate packages specific to a site,
+implementation, user, or directory.
* Menu:
@@ -86,10 +86,10 @@ sort of numbers are available from an implementation.
Other features correspond to the presence of sets of Scheme procedures
or syntax (macros).
- - Function: provided? FEATURE
+ - Function: provided? feature
Returns `#t' if FEATURE is supported by the current Scheme session.
- - Procedure: provide FEATURE
+ - Procedure: provide feature
Informs SLIB that FEATURE is supported. Henceforth `(provided?
FEATURE)' will return `#t'.
@@ -113,7 +113,7 @@ 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
+ - Procedure: require feature
* If `(provided? FEATURE)' is true, then `require' just returns
an unspecified value.
@@ -128,7 +128,7 @@ requested feature.
The catalog can also be queried using `require:feature->path'.
- - Function: require:feature->path FEATURE
+ - 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
@@ -248,8 +248,8 @@ be reloaded the next time the catalog is queried.
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.
+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
@@ -310,7 +310,7 @@ Require
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::.).
+ Porting::).
Here are features which SLIB (`require.scm') adds to *FEATURES*
when appropriate.
@@ -341,28 +341,28 @@ Require
In the following functions if the argument FEATURE is not a symbol it
is assumed to be a pathname.
- - Function: provided? FEATURE
+ - 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
+ - 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
+ - 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
+ - Procedure: provide feature
Assures that FEATURE is contained in `*features*' if FEATURE is a
symbol and `*modules*' otherwise.
- - Function: require:feature->path FEATURE
+ - 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
@@ -386,7 +386,7 @@ these procedures are file system dependent.
These procedures are provided by all implementations.
- - Function: make-vicinity PATH
+ - Function: make-vicinity path
Returns the vicinity of PATH for use by `in-vicinity'.
- Function: program-vicinity
@@ -417,7 +417,7 @@ These procedures are provided by all implementations.
a daemon) or if this concept is meaningless for the platform, then
`home-vicinity' returns `#f'.
- - Function: in-vicinity VICINITY FILENAME
+ - 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
@@ -428,7 +428,7 @@ These procedures are provided by all implementations.
to the value of `(user-vicinity)' is unspecified. For most systems
`in-vicinity' can be `string-append'.
- - Function: sub-vicinity VICINITY NAME
+ - 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
@@ -474,22 +474,22 @@ implementations.
implementation and the name of the operating system. An
unspecified value is returned.
- (slib:report-version) => slib "2c7" on scm "5b1" on unix |
+ (slib:report-version) => slib "2d2" 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
+ - Function: slib:report #t
provides a more verbose listing.
- - Function: slib:report FILENAME
+ - Function: slib:report filename
Writes the report to file `filename'.
(slib:report)
=>
- slib "2c7" on scm "5b1" on unix |
+ slib "2d2" on scm "5b1" on unix |
(implementation-vicinity) is "/home/jaffer/scm/"
(library-vicinity) is "/home/jaffer/slib/"
(scheme-file-suffix) is ".scm"
@@ -520,12 +520,12 @@ Input/Output
These procedures are provided by all implementations.
- - Procedure: file-exists? FILENAME
+ - 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
+ - Procedure: delete-file filename
Deletes the file specified by FILENAME. If FILENAME can not be
deleted, `#f' is returned. Otherwise, `#t' is returned.
@@ -539,20 +539,20 @@ These procedures are provided by all implementations.
directed.
- Procedure: force-output
- - Procedure: force-output PORT
+ - 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
+ - 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
+ - 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.
@@ -565,7 +565,7 @@ Legacy
These procedures are provided by all implementations.
- - Function: identity X
+ - Function: identity x
IDENTITY returns its argument.
Example:
@@ -586,7 +586,7 @@ implementations.
- Constant: nil
Defined as `#f'.
- - Function: last-pair L
+ - Function: last-pair l
Returns the last pair in the list L. Example:
(last-pair (cons 1 2))
=> (1 . 2)
@@ -602,18 +602,18 @@ System
These procedures are provided by all implementations.
- - Procedure: slib:load-source NAME
+ - 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
+ - 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
+ - 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
@@ -623,28 +623,28 @@ These procedures are provided by all implementations.
If an implementation does not support compiled code then
`slib:load' will be identical to `slib:load-source'.
- - Procedure: slib:eval OBJ
+ - 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
+ - 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 ...
+ - Procedure: slib:warn arg1 arg2 ...
Outputs a warning message containing the arguments.
- - Procedure: slib:error ARG1 ARG2 ...
+ - 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 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
@@ -686,7 +686,7 @@ Scheme Syntax Extension Packages
* Syntactic Closures:: 'syntactic-closures
* Syntax-Case Macros:: 'syntax-case
-Syntax extensions (macros) included with SLIB. Also *Note Structures::.
+Syntax extensions (macros) included with SLIB. |
* Fluid-Let:: 'fluid-let
* Yasos:: 'yasos, 'oop, 'collect
@@ -705,11 +705,11 @@ Defmacro
(gentemp) => scm:G0
(gentemp) => scm:G1
- - Function: defmacro:eval E
+ - Function: defmacro:eval e
Returns the `slib:eval' of expanding all defmacros in scheme
expression E.
- - Function: defmacro:load FILENAME
+ - 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.
@@ -717,20 +717,20 @@ Defmacro
definitions. The `macro:load' procedure does not affect the values
returned by `current-input-port' and `current-output-port'.
- - Function: defmacro? SYM
+ - Function: defmacro? sym
Returns `#t' if SYM has been defined by `defmacro', `#f' otherwise.
- - Function: macroexpand-1 FORM
- - Function: macroexpand FORM
+ - Function: macroexpand-1 form
+ - Function: macroexpand form
If FORM is a macro call, `macroexpand-1' will expand the macro
call once and return it. A FORM is considered to be a macro call
- only if it is a cons whose `car' is a symbol for which a `defmacr'
- has been defined.
+ 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 ...
+ - 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',
@@ -741,7 +741,7 @@ Defmacroexpand
`(require 'defmacroexpand)'
- - Function: defmacro:expand* E
+ - Function: defmacro:expand* e
Returns the result of expanding all defmacros in scheme expression
E.
@@ -759,15 +759,15 @@ Otherwise, one of the R4RS macros implemetations is loaded.
The SLIB R4RS macro implementations support the following uniform
interface:
- - Function: macro:expand SEXPRESSION
+ - Function: macro:expand sexpression
Takes an R4RS expression, macro-expands it, and returns the result
of the macro expansion.
- - Function: macro:eval SEXPRESSION
+ - 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
+ - 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
@@ -784,7 +784,7 @@ 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'.
+R4RS) by Dorai Sitaram, (dorai @ cs.rice.edu) using `defmacro'.
* generating hygienic global `define-syntax' Macro-by-Example macros
*cheaply*.
@@ -797,6 +797,7 @@ R4RS) by Dorai Sitaram, (dorai@cs.rice.edu) using `defmacro'.
* don't suffer the overhead of redefining the repl if `defmacro'
natively supported (most implementations)
+
Caveat
------
@@ -812,7 +813,7 @@ 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
+ - Macro: define-syntax keyword transformer-spec
The KEYWORD is an identifier, and the TRANSFORMER-SPEC should be
an instance of `syntax-rules'.
@@ -829,7 +830,7 @@ Syntax-Case Macros::.
(let* (( name2 val2) ...)
body1 body2 ...)))))
- - Macro: syntax-rules LITERALS SYNTAX-RULE ...
+ - Macro: syntax-rules literals syntax-rule ...
LITERALS is a list of identifiers, and each SYNTAX-RULE should be
of the form
@@ -861,19 +862,19 @@ Macros That Work
in that it does not expand derived expression types to primitive
expression types.
- - Function: macro:expand EXPRESSION
- - Function: macwork:expand EXPRESSION
+ - 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
+ - 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
+ - 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
@@ -1039,19 +1040,19 @@ Syntactic Closures
`(require 'syntactic-closures)'
- - Function: macro:expand EXPRESSION
- - Function: synclo:expand EXPRESSION
+ - 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
+ - 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
+ - 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
@@ -1136,13 +1137,14 @@ closures facility.
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: transformer expression
Syntax: It is an error if this syntax occurs except as a
TRANSFORMER SPEC.
@@ -1204,7 +1206,7 @@ procedures `make-syntactic-closure' and `capture-syntactic-environment'.
`make-syntactic-closure' to close the form in a syntactic
environment.
- - Function: make-syntactic-closure ENVIRONMENT FREE-NAMES FORM
+ - 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
@@ -1238,7 +1240,7 @@ procedures `make-syntactic-closure' and `capture-syntactic-environment'.
To obtain a syntactic environment other than the usage
environment, use `capture-syntactic-environment'.
- - Function: capture-syntactic-environment PROCEDURE
+ - 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,
@@ -1357,7 +1359,7 @@ 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
+ - Function: identifier? object
Returns `#t' if OBJECT is an identifier, otherwise returns `#f'.
Examples:
(identifier? 'a)
@@ -1390,8 +1392,8 @@ roles of the substituted input subforms.
environment as the symbol `else' means in the transformer
environment.
- - Function: identifier=? ENVIRONMENT1 IDENTIFIER1 ENVIRONMENT2
- IDENTIFIER2
+ - 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
@@ -1440,19 +1442,19 @@ Syntax-Case Macros
`(require 'syntax-case)'
- - Function: macro:expand EXPRESSION
- - Function: syncase:expand EXPRESSION
+ - 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
+ - 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
+ - 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
@@ -1463,9 +1465,9 @@ Syntax-Case Macros
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:
+ 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...
@@ -1494,7 +1496,7 @@ distribution by anonymous FTP in
(require 'syntax-case)
(require 'repl)
(repl:top-level macro:eval)
- See the section Repl (*note Repl::.) for more information.
+ 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
@@ -1533,7 +1535,7 @@ 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).
+(dyb @ iuvax.cs.indiana.edu).
Note from maintainer
--------------------
@@ -1563,7 +1565,7 @@ 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
+`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.
@@ -1607,7 +1609,7 @@ Terms
"Operation"
A METHOD.
-*Notes:*
+_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
@@ -1618,7 +1620,7 @@ Terms
dispatch is by a procedure call a la CLOS rather than by `send'
syntax a la Smalltalk.
-*Disclaimer:*
+_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.
@@ -1629,12 +1631,12 @@ File: slib.info, Node: Yasos interface, Next: Setters, Prev: Yasos terms, Up
Interface
---------
- - Syntax: define-operation `('OPNAME SELF ARG ...`)' DEFAULT-BODY
+ - 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?
+ - 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.
@@ -1644,8 +1646,8 @@ Interface
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 ...
+ - 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
@@ -1653,21 +1655,21 @@ Interface
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 ...
+ - 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
+ - Procedure: print obj port
A default `print' operation is provided which is just `(format
- PORT OBJ)' (*note Format::.) for non-instances and prints OBJ
+ PORT OBJ)' (*note Format::) for non-instances and prints OBJ
preceded by `#<INSTANCE>' for instances.
- - Function: size OBJ
+ - 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.
+ (*note Collections::) may override the default in an obvious way.

File: slib.info, Node: Setters, Next: Yasos examples, Prev: Yasos interface, Up: Yasos
@@ -1681,7 +1683,7 @@ 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::.).
+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!'.
@@ -1691,7 +1693,7 @@ Several setters are predefined, corresponding to getters `car', `cdr',
Research and Technology). Common LISP provides similar facilities
through `setf'.
- - Function: setter GETTER
+ - 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!':
@@ -1699,7 +1701,7 @@ through `setf'.
((setter string-ref) foo 0 #\F) ; set element 0 of foo
foo => "Foo"
- - Syntax: set PLACE NEW-VALUE
+ - 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
@@ -1712,17 +1714,17 @@ through `setf'.
(set foo "foo") ; like set!
foo => "foo"
- - Procedure: add-setter GETTER SETTER
+ - 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
+ - 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
+ - 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
@@ -1840,7 +1842,10 @@ Textual Conversion Packages
* Format:: Common-Lisp Format
* Standard Formatted I/O:: Posix printf and scanf
* Programs and Arguments::
-* HTML HTTP and CGI:: Generate pages and serve WWW sites
+* HTML::
+* HTML Tables:: Databases meet HTML
+* HTTP and CGI:: Serve WWW sites
+* URI:: Uniform Resource Identifier
* Printing Scheme:: Nicely
* Time and Date::
* Vector Graphics::
@@ -1968,7 +1973,7 @@ or
(set! *syn-defs* *syn-ignore-whitespace*)
- - Function: prec:define-grammar RULE1 ...
+ - 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.
@@ -1977,8 +1982,8 @@ variable (for use when calling `prec:parse').
(define my-ruleset *syn-defs*)
- - Function: prec:parse RULESET DELIM
- - Function: prec:parse RULESET DELIM PORT
+ - 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*.
@@ -2010,7 +2015,7 @@ File: slib.info, Node: Token definition, Next: Nud and Led Definition, Prev:
Token definition
----------------
- - Function: tok:char-group GROUP CHARS CHARS-PROC
+ - 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.
@@ -2085,7 +2090,7 @@ In his paper,
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*
+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
@@ -2097,7 +2102,7 @@ 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 ...
+ - 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
@@ -2107,7 +2112,7 @@ 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 ...
+ - 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
@@ -2140,19 +2145,19 @@ 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
+ - 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
+ - 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 ...
+ - 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
@@ -2169,7 +2174,7 @@ will both match token strings; i.e. tokens resulting from token groups.
* The ruleset in effect before TK was parsed is restored; RULE1
... are forgotten.
- - Function: prec:infix TK SOP LBP BP RULE1 ...
+ - 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:
@@ -2188,7 +2193,7 @@ will both match token strings; i.e. tokens resulting from token groups.
* The ruleset in effect before TK was parsed is restored; RULE1
... are forgotten.
- - Function: prec:nary TK SOP BP
+ - 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:
@@ -2201,7 +2206,7 @@ will both match token strings; i.e. tokens resulting from token groups.
the LEFT expression, and the parsed expressions is
incorporated.
- - Function: prec:postfix TK SOP LBP
+ - 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:
@@ -2210,7 +2215,7 @@ will both match token strings; i.e. tokens resulting from token groups.
built. Otherwise, the list of SOP and the LEFT expression is
incorporated.
- - Function: prec:prestfix TK SOP BP RULE1 ...
+ - 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
@@ -2227,14 +2232,14 @@ will both match token strings; i.e. tokens resulting from token groups.
* The ruleset in effect before TK was parsed is restored; RULE1
... are forgotten.
- - Function: prec:commentfix TK STP MATCH RULE1 ...
+ - 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.
+ 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).
@@ -2247,7 +2252,7 @@ will both match token strings; i.e. tokens resulting from token groups.
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 ...
+ - 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
@@ -2267,7 +2272,7 @@ will both match token strings; i.e. tokens resulting from token groups.
* The ruleset in effect before TK was parsed is restored; RULE1
... are forgotten.
- - Function: prec:inmatchfix TK SOP SEP MATCH LBP RULE1 ...
+ - 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:
@@ -2308,7 +2313,7 @@ File: slib.info, Node: Format Interface, Next: Format Specification, Prev: Fo
Format Interface
----------------
- - Function: format DESTINATION FORMAT-STRING . ARGUMENTS
+ - 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
@@ -2441,7 +2446,7 @@ directive parameter descriptions.
`~:R'
print a number as an ordinal English number.
-`~:@R'
+`~R'
print a number as a cardinal English number.
`~P'
@@ -2783,11 +2788,11 @@ 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 ...
+ - 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.
@@ -2850,7 +2855,7 @@ Standard Formatted Output
`%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::.).
+ Formatted Input::).
`0'
Pad the field with zeros instead of spaces. The zeros
@@ -2861,9 +2866,9 @@ Standard Formatted Output
* 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;
+ `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.
+ 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)
@@ -2916,10 +2921,15 @@ Standard Formatted Output
Exact Conversions
.................
+ `b', `B' |
+ Print an integer as an unsigned binary number. |
+ |
+ _Note:_ `%b' and `%B' are SLIB extensions. |
+ |
`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::.).
+ `scanf' for input (*note Standard Formatted Input::).
`o'
Print an integer as an unsigned octal number.
@@ -2944,13 +2954,18 @@ Inexact Conversions
between mantissa and exponont.
`g', `G'
- Print a floating-point number in either fixed or exponential |
+ 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
+ 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
.................
@@ -2972,12 +2987,12 @@ Other Conversions
precision specifies the maximum number of characters to
output; otherwise as many characters as needed are output.
- *Note:* `%a' and `%A' are SLIB extensions.
+ _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 `%%'.
+ is an error to specify flags, field width, precision, or type |
+ modifiers with `%%'. |

File: slib.info, Node: Standard Formatted Input, Prev: Standard Formatted Output, Up: Standard Formatted I/O
@@ -2987,13 +3002,13 @@ Standard Formatted Input
`(require 'scanf)'
- - Function: scanf-read-list FORMAT
- - Function: scanf-read-list FORMAT PORT
- - Function: scanf-read-list FORMAT STRING
+ - 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 ...
+ - 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.
@@ -3041,6 +3056,7 @@ Standard Formatted Input
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
@@ -3051,7 +3067,7 @@ Standard Formatted Input
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
+ _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
@@ -3138,7 +3154,7 @@ Standard Formatted Input
offending character is left unread in the input stream.

-File: slib.info, Node: Programs and Arguments, Next: HTML HTTP and CGI, Prev: Standard Formatted I/O, Up: Textual Conversion Packages
+File: slib.info, Node: Programs and Arguments, Next: HTML, Prev: Standard Formatted I/O, Up: Textual Conversion Packages
Program and Arguments
=====================
@@ -3162,7 +3178,7 @@ Getopt
This routine implements Posix command line argument parsing. Notice
that returning values through global variables means that `getopt' is
-*not* reentrant.
+_not_ reentrant.
- Variable: *optind*
Is the index of the current element of the command line. It is
@@ -3173,7 +3189,7 @@ that returning values through global variables means that `getopt' is
Is set by getopt to the (string) option-argument of the current
option.
- - Procedure: getopt ARGC ARGV OPTSTRING
+ - 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
@@ -3260,7 +3276,7 @@ that returning values through global variables means that `getopt' is
Getopt-
-------
- - Function: getopt- ARGC ARGV OPTSTRING
+ - 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'
@@ -3302,7 +3318,7 @@ Command Line
`(require 'read-command)'
- - Function: read-command PORT
+ - 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
@@ -3359,7 +3375,7 @@ Command Line
treated as whitespace by `read-dommand-line' and backslashes
before <newline>s in comments are also ignored.
- - Function: read-options-file FILENAME
+ - 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
@@ -3391,18 +3407,25 @@ 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
+ - Function: make-parameter-list parameter-names
Returns an empty parameter-list with slots for PARAMETER-NAMES.
- - Function: parameter-list-ref PARAMETER-LIST PARAMETER-NAME
+ - Function: parameter-list-ref parameter-list parameter-name
PARAMETER-NAME must name a valid slot of PARAMETER-LIST.
`parameter-list-ref' returns the value of parameter PARAMETER-NAME
of PARAMETER-LIST.
- - Procedure: adjoin-parameters! PARAMETER-LIST PARAMETER1 ...
+ - 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
+ - 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
@@ -3412,7 +3435,7 @@ PARAMETER-NAME.
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
+ - 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
@@ -3420,14 +3443,14 @@ PARAMETER-NAME.
returned by calling the corresponding DEFAULTER with
PARAMETER-LIST as its argument.
- - Function: check-parameters CHECKS PARAMETER-LIST
+ - Function: check-parameters checks parameter-list
CHECKS is a list of procedures whose order matches the order of
the PARAMETER-NAMEs in the call to `make-parameter-list' which
created PARAMETER-LIST.
`check-parameters' returns PARAMETER-LIST if each CHECK of the
corresponding PARAMETER-LIST returns non-false. If some CHECK
- returns `#f' an error is signaled.
+ returns `#f' a warning is signaled.
In the following procedures ARITIES is a list of symbols. The elements
of `arities' can be:
@@ -3447,12 +3470,11 @@ of `arities' can be:
`nary1'
One or more of parameters are acceptable.
- - Function: parameter-list->arglist POSITIONS ARITIES TYPES
- PARAMETER-LIST
+ - 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) of type TYPES.
+ 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'
@@ -3467,26 +3489,47 @@ Getopt Parameter lists
`(require 'getopt-parameters)'
- - Function: getopt->parameter-list ARGC ARGV OPTNAMES ARITIES TYPES
- ALIASES
+ - Function: getopt->parameter-list argc argv optnames arities types
+ aliases desc ...
Returns ARGV converted to a parameter-list. OPTNAMES are the
- parameter-names. ALIASES is a list of lists of strings and
- elements of OPTNAMES. Each of these strings which have length of
- 1 will be treated as a single <-> option by `getopt'. Longer
- strings will be treated as long-named options (*note getopt-:
- Getopt.).
-
- - Function: getopt->arglist ARGC ARGV OPTNAMES POSITIONS ARITIES TYPES
- DEFAULTERS CHECKS ALIASES
+ 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.
+ 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 are printed to `current-error-port'.
+the options (and argument strings DESC ...) are printed to
+`current-error-port'.
(begin
(set! *optind* 1)
@@ -3533,8 +3576,8 @@ Filenames
`(require 'filename)' or `(require 'glob)'
- - Function: filename:match?? PATTERN
- - Function: filename:match-ci?? PATTERN
+ - 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,
@@ -3559,8 +3602,8 @@ Filenames
last character in the set.
- - Function: filename:substitute?? PATTERN TEMPLATE
- - Function: filename:substitute-ci?? PATTERN TEMPLATE
+ - 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
@@ -3589,7 +3632,7 @@ Filenames
((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1))) "ABZ")
=> "ZA"
- - Function: replace-suffix STR OLD NEW
+ - 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
@@ -3608,7 +3651,7 @@ 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
+its first argument a parameter-list (*note Parameter lists::). This
parameter-list argument PARMS contains named associations. Batch
currently uses 2 of these:
@@ -3630,10 +3673,10 @@ currently uses 2 of these:
* *unknown*
`batch.scm' uses 2 enhanced relational tables (*note Database
-Utilities::.) to store information linking the names of
+Utilities::) to store information linking the names of
`operating-system's to `batch-dialect'es.
- - Function: batch:initialize! DATABASE
+ - Function: batch:initialize! database
Defines `operating-system' and `batch-dialect' tables and adds the
domain `operating-system' to the enhanced relational database
DATABASE.
@@ -3641,10 +3684,10 @@ Utilities::.) to store information linking the names of
- 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.
+ Configuration::) unless `(software-type)' is `unix', in which case
+ finer distinctions are made.
- - Function: batch:call-with-output-script PARMS FILE PROC
+ - 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.
@@ -3654,65 +3697,65 @@ Utilities::.) to store information linking the names of
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'. |
+ - 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 ... |
+ - 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 ...
+ - 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). |
+ _Note:_ `batch:run-script' and `batch:try-command' are not the
+ same for some operating systems (VMS).
- - Function: batch:comment PARMS LINE1 ...
+ - Function: batch:comment parms line1 ...
Writes comment lines LINE1 ... to the `batch-port' in PARMS.
- - Function: batch:lines->file PARMS FILE LINE1 ...
+ - 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
+ - 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
+ - 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
+ - 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.
@@ -3720,22 +3763,22 @@ scripts:
(truncate-up-to "/usr/local/lib/slib/batch.scm" "/")
=> "batch.scm"
- - Function: string-join JOINER STRING1 ...
+ - 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
+ - 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
+ - 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
+ - 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!'.
@@ -3771,10 +3814,10 @@ Here is an example of the use of most of batch's procedures:
" printf(\"hello world\\n\");"
" return 0;"
"}" )
- (batch:command my-parameters "cc" "-c" "hello.c") |
- (batch:command my-parameters "cc" "-o" "hello" |
+ (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:command my-parameters "hello")
(batch:delete-file my-parameters "hello")
(batch:delete-file my-parameters "hello.c")
(batch:delete-file my-parameters "hello.o")
@@ -3784,7 +3827,7 @@ Here is an example of the use of most of batch's procedures:
Produces the file `my-batch':
#!/bin/sh
- # "my-batch" script created by SLIB/batch Sun Oct 31 18:24:10 1999 |
+ # "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
@@ -3809,208 +3852,515 @@ When run, `my-batch' prints:
hello world

-File: slib.info, Node: HTML HTTP and CGI, Next: Printing Scheme, Prev: Programs and Arguments, Up: Textual Conversion Packages
+File: slib.info, Node: HTML, Next: HTML Tables, Prev: Programs and Arguments, Up: Textual Conversion Packages
-HTML Forms
-==========
+HTML
+====
`(require 'html-form)'
- - Variable: *html:output-port*
- Procedure names starting with `html:' send their output to the
- port *HTML:OUTPUT-PORT*. *HTML:OUTPUT-PORT* is initially the
- current output port.
-
- - Function: make-atval TXT
+ - Function: html:atval txt
Returns a string with character substitutions appropriate to send
TXT as an "attribute-value".
- - Function: make-plain TXT
+ - Function: html:plain txt
Returns a string with character substitutions appropriate to send
TXT as an "plain-text".
- - Function: html:start-page TITLE BACKLINK TAGS ...
- - Function: html:start-page TITLE BACKLINK
- - Function: html:start-page TITLE
- Outputs headers for an HTML page named TITLE. If string arguments
- BACKLINK ... are supplied they are printed verbatim within the
- <HEAD> section.
+ - 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
- - Function: html:end-page
- Outputs HTML codes to end a page.
+ 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.
- - Function: html:pre LINE1 LINE ...
- Writes (using `html:printf') 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.
+ For other types of domains:
- - Function: html:comment LINE1 LINE ...
- Writes (using `html:printf') the strings LINE1 as HTML comments.
+ `single'
+ text area
+
+ `optional'
+ text area
+
+ `boolean'
+ check box
+
+ `nary'
+ text area
+
+ `nary1'
+ text area
+
+ - Function: form:delimited pname doc aliat arity default-list
+ foreign-values
+ Returns a HTML string for a form element embedded in a line of a
+ delimited list. Apply map `form:delimited' to the list returned by
+ `command->p-specs'.
+
+ - Function: command->p-specs rdb command-table command
+ The symbol COMMAND-TABLE names a command table in the RDB
+ relational database. The symbol COMMAND names a key in
+ COMMAND-TABLE.
+
+ `command->p-specs' returns a list of lists of PNAME, DOC, ALIAT,
+ ARITY, DEFAULT-LIST, and FOREIGN-VALUES. The returned list has
+ one element for each parameter of command COMMAND.
+
+ This example demonstrates how to create a HTML-form for the `build'
+ command.
+
+ (require (in-vicinity (implementation-vicinity) "build.scm"))
+ (call-with-output-file "buildscm.html"
+ (lambda (port)
+ (display
+ (string-append
+ (html:head 'commands)
+ (html:body
+ (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n"
+ (html:plain 'build)
+ (html:plain ((comtab 'get 'documentation) 'build)))
+ (html:form
+ 'post
+ (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi")
+ (apply html:delimited-list
+ (apply map form:delimited
+ (command->p-specs build '*commands* 'build)))
+ (form:submit 'build)
+ (form:reset))))
+ port)))
+
+
+File: slib.info, Node: HTML Tables, Next: HTTP and CGI, Prev: HTML, Up: Textual Conversion Packages
HTML Tables
===========
- - Function: html:start-table CAPTION
+ `(require 'db->html)'
+
+ - Function: html:table options row ...
- - Function: html:end-table
+ - Function: html:caption caption align
+ - Function: html:caption caption
+ ALIGN can be `top' or `bottom'.
- - Function: html:heading COLUMNS
+ - Function: html:heading columns
Outputs a heading row for the currently-started table.
- - Function: html:href-heading COLUMNS URLS
- Outputs a heading row with column-names COLUMNS linked to URLs
- URLS.
+ - Function: html:href-heading columns uris
+ Outputs a heading row with column-names COLUMNS linked to URIs
+ URIS.
- - Function: make-row-converter K FOREIGNS
+ - 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.
- `make-row-converter' returns a procedure taking a row for its
- single argument. This returned procedure prints the table row to
- *HTML:OUTPUT-PORT*.
+ `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
+ - Function: table-name->filename table-name
Returns the symbol TABLE-NAME converted to a filename.
- - Function: table->html CAPTION DB TABLE-NAME MATCH-KEY1 ...
- Writes HTML for DB table TABLE-NAME to *HTML:OUTPUT-PORT*.
+ - 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->page DB TABLE-NAME INDEX-FILENAME
- Writes a complete HTML page to *HTML:OUTPUT-PORT*. The string
- INDEX-FILENAME names the page which refers to this one.
+ - 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.
- - Function: catalog->html DB CAPTION
- Writes HTML for the catalog table of DB to *HTML:OUTPUT-PORT*.
+ The optional ARGS ... arguments restrict actions to a subset of
+ the table. *Note match-key: Table Operations.
- - Function: catalog->page DB CAPTION
- Writes a complete HTML page for the catalog of DB to
- *HTML:OUTPUT-PORT*.
+ - Function: catalog->html db caption arg ...
+ Returns HTML string for the catalog table of DB.
-HTML Forms
-==========
+HTML editing tables
+-------------------
- - Function: html:start-form METHOD ACTION
- The symbol METHOD is either `get', `head', `post', `put', or
- `delete'. `html:start-form' prints the header for an HTML "form".
+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.
- - Function: html:end-form PNAME SUBMIT-LABEL
- `html:end-form' prints the footer for an HTML "form". The string
- SUBMIT-LABEL appears on the button which submits the form.
+The behavior of edited rows is:
- - Function: command->html RDB COMMAND-TABLE COMMAND METHOD ACTION
- The symbol COMMAND-TABLE names a command table in the RDB
- relational database.
+ * If no fields are changed, then no change is made to the table.
- `command->html' writes an HTML-2.0 "form" for command COMMAND to
- the current-output-port. The `SUBMIT' button, which is labeled
- COMMAND, invokes the URI ACTION with method METHOD with a hidden
- attribute `*command*' bound to the command symbol submitted.
+ * If the primary keys equal null-keys (parameter defaults), and no
+ other user has modified that row, then that row is deleted.
- An action may invoke a CGI script
- (`http://www.my-site.edu/cgi-bin/search.cgi') or HTTP daemon
- (`http://www.my-site.edu:8001').
+ * 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.
- This example demonstrates how to create a HTML-form for the `build'
- command.
+ * 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.
- (require (in-vicinity (implementation-vicinity) "build.scm"))
- (call-with-output-file "buildscm.html"
- (lambda (port)
- (fluid-let ((*html:output-port* port))
- (html:start-page 'commands)
- (command->html
- build '*commands* 'build 'post
- (or "/cgi-bin/build.cgi"
- "http://localhost:8081/buildscm"))
- html:end-page)))
-
-HTTP and CGI service
-====================
+ * 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.
- `(require 'html-form)'
+ * 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: cgi:serve-command RDB COMMAND-TABLE
- Reads a `"POST"' or `"GET"' query from `(current-input-port)' and
- executes the encoded command from COMMAND-TABLE in
- relational-database RDB.
+ - 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.
- This example puts up a plain-text page in response to a CGI query.
+ - 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.
- (display "Content-Type: text/plain") (newline) (newline)
- (require 'html-form)
- (load (in-vicinity (implementation-vicinity) "build.scm"))
- (cgi:serve-command build '*commands*)
+ Optional ARGS are expressions (lists) added to the call to
+ `command:modify-table'.
- - Function: serve-urlencoded-command RDB COMMAND-TABLE URLENCODED
- Reads attribute-value pairs from URLENCODED, converts them to
- parameters and invokes the RDB command named by the parameter
- `*command*'.
+ The domain name of a column determines the expected arity of the
+ data stored in that column. Domain names ending in:
- - Function: http:serve-query INPUT-PORT OUTPUT-PORT SERVE-PROC
- reads the "query-string" from INPUT-PORT. If this is a valid
- `"POST"' or `"GET"' query, then `http:serve-query' calls
- SERVE-PROC with two arguments, the query-string and the
- header-alist.
+ `*'
+ have arity `nary';
+
+ `+'
+ have arity `nary1'.
+
+ - Function: html:editable-row-converter k names edit-point
+ edit-converter
+ The positive integer K is the primary-key-limit (number of
+ primary-keys) of the table. NAMES is a list of the field-names.
+ EDIT-POINT is the list of primary-keys denoting the row to edit
+ (or #f). EDIT-CONVERTER is the procedure called with K, NAMES,
+ and the row to edit.
+
+ `html:editable-row-converter' returns a procedure taking a row for
+ its single argument. This returned procedure returns the html
+ string for that table row.
+
+ Each HTML table constructed using `html:editable-row-converter'
+ has first K fields (typically the primary key fields) of each row
+ linked to a text encoding of these fields (the result of calling
+ `row->anchor'). The page so referenced typically allows the user
+ to edit fields of that row.
+
+HTML databases
+--------------
+
+ - Function: db->html-files db dir index-filename caption
+ DB must be a relational database. DIR must be #f or a non-empty
+ string naming an existing sub-directory of the current directory.
+
+ `db->html-files' creates an html page for each table in the
+ database DB in the sub-directory named DIR, or the current
+ directory if DIR is #f. The top level page with the catalog of
+ tables (captioned CAPTION) is written to a file named
+ INDEX-FILENAME.
+
+ - Function: db->html-directory db dir index-filename
+ - Function: db->html-directory db dir
+ DB must be a relational database. DIR must be a non-empty string
+ naming an existing sub-directory of the current directory or one
+ to be created. The optional string INDEX-FILENAME names the
+ filename of the top page, which defaults to `index.html'.
+
+ `db->html-directory' creates sub-directory DIR if neccessary, and
+ calls `(db->html-files DB DIR INDEX-FILENAME DIR)'. The `file:'
+ URI of INDEX-FILENAME is returned.
+
+ - Function: db->netscape db dir index-filename
+ - Function: db->netscape db dir
+ `db->netscape' is just like `db->html-directory', but calls
+ `browse-url-netscape' with the uri for the top page after the
+ pages are created.
+
+
+File: slib.info, Node: HTTP and CGI, Next: URI, Prev: HTML Tables, Up: Textual Conversion Packages
+
+HTTP and CGI
+============
+
+ `(require 'http)' or `(require 'cgi)'
+
+ - Function: http:header alist
+ Returns a string containing lines for each element of ALIST; the
+ `car' of which is followed by `: ', then the `cdr'.
+
+ - Function: http:content alist body ...
+ Returns the concatenation of strings BODY with the `(http:header
+ ALIST)' and the `Content-Length' prepended.
+
+ - Variable: *http:byline*
+ String appearing at the bottom of error pages.
+
+ - Function: http:error-page status-code reason-phrase html-string ...
+ STATUS-CODE and REASON-PHRASE should be an integer and string as
+ specified in `RFC 2068'. The returned page (string) will show the
+ STATUS-CODE and REASON-PHRASE and any additional HTML-STRINGS ...;
+ with *HTTP:BYLINE* or SLIB's default at the bottom.
+
+ - Function: http:forwarding-page title delay uri html-string ...
+ The string or symbol TITLE is the page title. DELAY is a
+ non-negative integer. The HTML-STRINGS ... are typically used to
+ explain to the user why this page is being forwarded.
+
+ `http:forwarding-page' returns an HTML string for a page which
+ automatically forwards to URI after DELAY seconds. The returned
+ page (string) contains any HTML-STRINGS ... followed by a manual
+ link to URI, in case the browser does not forward automatically.
+
+ - Function: http:serve-query serve-proc input-port output-port
+ reads the "URI" and "query-string" from INPUT-PORT. If the query
+ is a valid `"POST"' or `"GET"' query, then `http:serve-query' calls
+ SERVE-PROC with three arguments, the REQUEST-LINE, QUERY-STRING,
+ and HEADER-ALIST. Otherwise, `http:serve-query' calls SERVE-PROC
+ with the REQUEST-LINE, #f, and HEADER-ALIST.
+
+ If SERVE-PROC returns a string, it is sent to OUTPUT-PORT. If
+ SERVE-PROC returns a list, then an error page with number 525 and
+ strings from the list. If SERVE-PROC returns #f, then a `Bad
+ Request' (400) page is sent to OUTPUT-PORT.
Otherwise, `http:serve-query' replies (to OUTPUT-PORT) with
appropriate HTML describing the problem.
- This example services HTTP queries from port 8081:
+ This example services HTTP queries from PORT-NUMBER:
(define socket (make-stream-socket AF_INET 0))
- (socket:bind socket 8081)
- (socket:listen socket 10)
- (dynamic-wind
- (lambda () #f)
- (lambda ()
- (do ((port (socket:accept socket)
- (socket:accept socket)))
- (#f)
+ (and (socket:bind socket port-number) ; AF_INET INADDR_ANY
+ (socket:listen socket 10) ; Queue up to 10 requests.
(dynamic-wind
- (lambda () #f)
- (lambda ()
- (fluid-let ((*html:output-port* port))
- (http:serve-query
- port port
- (lambda (query-string header)
- (http:send-header
- '(("Content-Type" . "text/plain")))
- (with-output-to-port port
- (lambda ()
- (serve-urlencoded-command
- build '*commands* query-string)))))))
- (lambda () (close-port port)))))
- (lambda () (close-port socket)))
+ (lambda () #f)
+ (lambda ()
+ (do ((port (socket:accept socket) (socket:accept socket)))
+ (#f)
+ (let ((iport (duplicate-port port "r"))
+ (oport (duplicate-port port "w")))
+ (http:serve-query build:serve iport oport)
+ (close-port iport)
+ (close-port oport))
+ (close-port port)))
+ (lambda () (close-port socket))))
+
+ - Function: cgi:serve-query serve-proc
+ reads the "URI" and "query-string" from `(current-input-port)'.
+ If the query is a valid `"POST"' or `"GET"' query, then
+ `cgi:serve-query' calls SERVE-PROC with three arguments, the
+ REQUEST-LINE, QUERY-STRING, and HEADER-ALIST. Otherwise,
+ `cgi:serve-query' calls SERVE-PROC with the REQUEST-LINE, #f, and
+ HEADER-ALIST.
+
+ If SERVE-PROC returns a string, it is sent to
+ `(current-input-port)'. If SERVE-PROC returns a list, then an
+ error page with number 525 and strings from the list. If
+ SERVE-PROC returns #f, then a `Bad Request' (400) page is sent to
+ `(current-input-port)'.
+
+ Otherwise, `cgi:serve-query' replies (to `(current-input-port)')
+ with appropriate HTML describing the problem.
+
+ - Function: make-query-alist-command-server rdb command-table
+ - Function: make-query-alist-command-server rdb command-table #t
+ Returns a procedure of one argument. When that procedure is called
+ with a QUERY-ALIST (as returned by `uri:decode-query', the value
+ of the `*command*' association will be the command invoked in
+ COMMAND-TABLE. If `*command*' is not in the QUERY-ALIST then the
+ value of `*suggest*' is tried. If neither name is in the
+ QUERY-ALIST, then the literal value `*default*' is tried in
+ COMMAND-TABLE.
+
+ If optional third argument is non-false, then the command is called
+ with just the parameter-list; otherwise, command is called with the
+ arguments described in its table.
+
+
+File: slib.info, Node: URI, Next: Printing Scheme, Prev: HTTP and CGI, Up: Textual Conversion Packages
+
+URI
+===
+
+ `(require 'uri)'
+
+Implements "Uniform Resource Identifiers" (URI) as described in RFC
+2396.
+
+ - Function: make-uri
+ - Function: make-uri fragment
+ - Function: make-uri query fragment
+ - Function: make-uri path query fragment
+ - Function: make-uri authority path query fragment
+ - Function: make-uri scheme authority path query fragment
+ Returns a Uniform Resource Identifier string from component
+ arguments.
- - Function: http:read-request-line PORT
- Reads the first non-blank line from PORT and, if successful,
- returns a list of three itmes from the request-line:
+ - 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.
- 0. Method
+ (html:anchor "(section 7)")
+ =>
+ "<A NAME=\"(section%207)\"></A>"
- Either one of the symbols `options', `get', `head', `post',
- `put', `delete', or `trace'; Or a string.
+ - Function: html:link uri highlighted
+ Returns a string which links the HIGHLIGHTED text to URI.
- 1. Request-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.).
- A string. At the minimum, it will be the string `"/"'.
+ - 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.).
- 2. HTTP-Version
+ - 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.
- A string. For example, `HTTP/1.0'.
+ The PATH is a list of strings. If the first string is empty, then
+ the path is absolute; otherwise relative.
- - Function: cgi:read-query-string
- Reads the "query-string" from `(current-input-port)'.
- `cgi:read-query-string' reads a `"POST"' or `"GET"' queries,
- depending on the value of `(getenv "REQUEST_METHOD")'.
+ If the AUTHORITY component is a "Server-based Naming Authority",
+ then it is a list of the USERINFO, HOST, and PORT strings (or #f).
+ For other types of AUTHORITY components the AUTHORITY will be a
+ string.
+
+ (uri->tree "http://www.ics.uci.edu/pub/ietf/uri/#Related")
+ =>
+ (http "www.ics.uci.edu" ("" "pub" "ietf" "uri" "") #f "Related")
+
+`uric:' prefixes indicate procedures dealing with URI-components.
+
+ - Function: uric:encode uri-component allows
+ Returns a copy of the string URI-COMPONENT in which all "unsafe"
+ octets (as defined in RFC 2396) have been `%' "escaped".
+ `uric:decode' decodes strings encoded by `uric:encode'.
+
+ - Function: uric:decode uri-component
+ Returns a copy of the string URI-COMPONENT in which each `%'
+ escaped characters in URI-COMPONENT is replaced with the character
+ it encodes. This routine is useful for showing URI contents on
+ error pages.

-File: slib.info, Node: Printing Scheme, Next: Time and Date, Prev: HTML HTTP and CGI, Up: Textual Conversion Packages
+File: slib.info, Node: Printing Scheme, Next: Time and Date, Prev: URI, Up: Textual Conversion Packages
Printing Scheme
===============
@@ -4035,7 +4385,7 @@ 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
+ - Procedure: generic-write obj display? width output
OBJ
Scheme data value to transform.
@@ -4073,10 +4423,10 @@ Object-To-String
`(require 'object->string)'
- - Function: object->string OBJ
+ - Function: object->string obj
Returns the textual representation of OBJ as a string.
- - Function: object->limited-string OBJ LIMIT
+ - Function: object->limited-string obj limit
Returns the textual representation of OBJ as a string of length at
most LIMIT.
@@ -4088,8 +4438,8 @@ Pretty-Print
`(require 'pretty-print)'
- - Procedure: pretty-print OBJ
- - Procedure: pretty-print OBJ PORT
+ - 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.
@@ -4102,16 +4452,54 @@ Pretty-Print
-| (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
+ - 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
+ - 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.
@@ -4157,11 +4545,11 @@ Scheme datatypes.
reference time for `get-universal-time' in *Note Common-Lisp
Time::.
- - Function: difftime CALTIME1 CALTIME0
+ - 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
+ - Function: offset-time caltime offset
Returns the calendar time of CALTIME offset by OFFSET number of
seconds `(+ caltime offset)'.
@@ -4232,12 +4620,12 @@ Time Zone
local time is, and the "Daylight Savings Time" rules for changing
it.
- - Function: time-zone TZ-STRING
+ - 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
+ - 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
@@ -4259,16 +4647,16 @@ compatability. Because of shared state they are not thread-safe.
- Function: tzset
Returns the default time-zone.
- - Function: tzset TZ
+ - Function: tzset tz
Sets (and returns) the default time-zone to TZ.
- - Function: tzset TZ-STRING
+ - 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::.).
+ procedures which depend on the time zone (*note Time and Date::).
- Variable: *timezone*
Contains the difference, in seconds, between Greenwich Mean Time
@@ -4278,7 +4666,7 @@ compatability. Because of shared state they are not thread-safe.
- Variable: daylight?
is `#t' if the default timezone has rules for "Daylight Savings
- Time". *Note:* DAYLIGHT? does not tell you when 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.
@@ -4321,13 +4709,13 @@ Posix Time
8. 1 for daylight savings, 0 for regular time
- - Function: gmtime CALTIME
+ - Function: gmtime caltime
Converts the calendar time CALTIME to UTC and returns it.
- - Function: localtime CALTIME TZ
+ - Function: localtime caltime tz
Returns CALTIME converted to UTC relative to timezone TZ.
- - Function: localtime CALTIME
+ - 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
@@ -4335,26 +4723,26 @@ Posix Time
tzset: Time Zone.).
- - Function: gmktime UNIVTIME
+ - Function: gmktime univtime
Converts a vector of integers in GMT Coordinated Universal Time
(UTC) format to a calendar time.
- - Function: mktime UNIVTIME
+ - Function: mktime univtime
Converts a vector of integers in local Coordinated Universal Time
(UTC) format to a calendar time.
- - Function: mktime UNIVTIME TZ
+ - 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
+ - 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
+ - Function: gtime caltime
+ - Function: ctime caltime
+ - Function: ctime caltime tz
Equivalent to `(asctime (gmtime CALTIME))', `(asctime (localtime
CALTIME))', and `(asctime (localtime CALTIME TZ))', respectively.
@@ -4372,7 +4760,7 @@ Common-Lisp Time
since 00:00:00 Jan 1, 1900 GMT. Note that the reference time is
different from `current-time'.
- - Function: decode-universal-time UNIVTIME
+ - Function: decode-universal-time univtime
Converts UNIVTIME to "Decoded Time" format. Nine values are
returned:
0. seconds (0 - 61)
@@ -4397,9 +4785,9 @@ Common-Lisp Time
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
+ - 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
@@ -4424,7 +4812,7 @@ File: slib.info, Node: Tektronix Graphics Support, Prev: Vector Graphics, Up:
Tektronix Graphics Support
--------------------------
- *Note:* The Tektronix graphics support files need more work, and are
+ _Note:_ The Tektronix graphics support files need more work, and are
not complete.
Tektronix 4000 Series Graphics
@@ -4444,13 +4832,13 @@ sequences.
- Procedure: tek40:text
- - Procedure: tek40:linetype LINETYPE
+ - Procedure: tek40:linetype linetype
- - Procedure: tek40:move X Y
+ - Procedure: tek40:move x y
- - Procedure: tek40:draw X Y
+ - Procedure: tek40:draw x y
- - Procedure: tek40:put-text X Y STR
+ - Procedure: tek40:put-text x y str
- Procedure: tek40:reset
@@ -4467,15 +4855,15 @@ sequences.
- Procedure: tek41:graphics
- - Procedure: tek41:move X Y
+ - Procedure: tek41:move x y
- - Procedure: tek41:draw X Y
+ - Procedure: tek41:draw x y
- - Procedure: tek41:point X Y NUMBER
+ - Procedure: tek41:point x y number
- - Procedure: tek41:encode-x-y X Y
+ - Procedure: tek41:encode-x-y x y
- - Procedure: tek41:encode-int NUMBER
+ - Procedure: tek41:encode-int number

File: slib.info, Node: Schmooz, Prev: Vector Graphics, Up: Textual Conversion Packages
@@ -4492,16 +4880,16 @@ imported into the documentation using the Texinfo command `@include'.
process files. Files containing schmooz documentation should not
contain `(require 'schmooz)'.
- - Procedure: schmooz FILENAMEscm ...
+ - 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 ...
+ - 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
@@ -4510,7 +4898,7 @@ contain `(require 'schmooz)'.
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
+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
@@ -4592,6 +4980,7 @@ Mathematical Packages
* Cyclic Checksum:: 'make-crc
* Plotting:: 'charplot
* Root Finding:: 'root
+* Minimizing:: 'minimize
* Commutative Rings:: 'commutative-ring
* Determinant:: 'determinant
@@ -4612,7 +5001,7 @@ representation.
Bitwise Operations
------------------
- - Function: logand N1 N1
+ - Function: logand n1 n1
Returns the integer which is the bit-wise AND of the two integer
arguments.
@@ -4620,7 +5009,7 @@ Bitwise Operations
(number->string (logand #b1100 #b1010) 2)
=> "1000"
- - Function: logior N1 N2
+ - Function: logior n1 n2
Returns the integer which is the bit-wise OR of the two integer
arguments.
@@ -4628,7 +5017,7 @@ Bitwise Operations
(number->string (logior #b1100 #b1010) 2)
=> "1110"
- - Function: logxor N1 N2
+ - Function: logxor n1 n2
Returns the integer which is the bit-wise XOR of the two integer
arguments.
@@ -4636,7 +5025,7 @@ Bitwise Operations
(number->string (logxor #b1100 #b1010) 2)
=> "110"
- - Function: lognot N
+ - Function: lognot n
Returns the integer which is the 2s-complement of the integer
argument.
@@ -4646,19 +5035,19 @@ Bitwise Operations
(number->string (lognot #b0) 2)
=> "-1"
- - Function: bitwise-if MASK N0 N1
+ - 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
+ - Function: logtest j k
(logtest j k) == (not (zero? (logand j k)))
(logtest #b0100 #b1011) => #f
(logtest #b0100 #b0111) => #t
- - Function: logcount N
+ - 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
@@ -4675,7 +5064,7 @@ Bitwise Operations
Bit Within Word
---------------
- - Function: logbit? INDEX J
+ - Function: logbit? index j
(logbit? index j) == (logtest (integer-expt 2 index) j)
(logbit? 0 #b1101) => #t
@@ -4684,7 +5073,7 @@ Bit Within Word
(logbit? 3 #b1101) => #t
(logbit? 4 #b1101) => #f
- - Function: copy-bit INDEX FROM BIT
+ - 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'.
@@ -4696,7 +5085,7 @@ Bit Within Word
Fields of Bits
--------------
- - Function: bit-field N START END
+ - 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.
@@ -4710,7 +5099,7 @@ Fields of Bits
(number->string (bit-field #b1101101010 4 9) 2)
=> "10110"
- - Function: copy-bit-field TO START END FROM
+ - 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
@@ -4722,7 +5111,7 @@ Fields of Bits
(number->string (copy-bit-field #b1101101010 0 4 -1) 2)
=> "1101101111"
- - Function: ash INT COUNT
+ - Function: ash int count
Returns an integer equivalent to `(inexact->exact (floor (* INT
(expt 2 COUNT))))'.
@@ -4732,7 +5121,7 @@ Fields of Bits
(number->string (ash #b1010 -1) 2)
=> "101"
- - Function: integer-length N
+ - Function: integer-length n
Returns the number of bits neccessary to represent N.
Example:
@@ -4743,7 +5132,7 @@ Fields of Bits
(integer-length #b1111)
=> 4
- - Function: integer-expt N K
+ - Function: integer-expt n k
Returns N raised to the non-negative integer exponent K.
Example:
@@ -4760,18 +5149,18 @@ Modular Arithmetic
`(require 'modular)'
- - Function: extended-euclid N1 N2
+ - 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
+ - Function: symmetric:modulus n
Returns `(quotient (+ -1 n) -2)' for positive odd integer N.
- - Function: modulus->integer MODULUS
+ - 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
+ - Function: modular:normalize modulus n
Returns the integer `(modulo N (modulus->integer MODULUS))' in the
representation specified by MODULUS.
@@ -4792,30 +5181,30 @@ For all of these functions, if the first argument (MODULUS) is:
If all the arguments are fixnums the computation will use only fixnums.
- - Function: modular:invertable? MODULUS K
+ - 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
+ - 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
+ - Function: modular:negate modulus k2
Returns (-K2) mod MODULUS.
- - Function: modular:+ MODULUS K2 K3
+ - Function: modular:+ modulus k2 k3
Returns (K2 + K3) mod MODULUS.
- - Function: modular:- MODULUS K2 K3
+ - Function: modular:- modulus k2 k3
Returns (K2 - K3) mod MODULUS.
- - Function: modular:* MODULUS K2 K3
+ - 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
+ - Function: modular:expt modulus k2 k3
Returns (K2 ^ K3) mod MODULUS.

@@ -4827,18 +5216,17 @@ 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. |
+ 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
+ - 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.
@@ -4846,20 +5234,20 @@ the Solovay-Strassen primality test. See |
PRIME:TRIALS the maxinum number of iterations of Solovay-Strassen
that will be done to test a number for primality.
- - Function: prime? N
+ - 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
+ - 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
+ - Function: primes> start count
Returns a list of the first COUNT prime numbers greater than START.
- - Function: factor K
+ - 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) <)'.
@@ -4875,17 +5263,17 @@ Random Numbers
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. |
+(<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
+ - 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.
@@ -4904,13 +5292,13 @@ from sequential bytes, tests fail. With the seed
function correctly as a random-number state object in another
implementation.
- - Function: copy-random-state STATE
+ - 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
+ - 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
@@ -4920,7 +5308,7 @@ from sequential bytes, tests fail. With the seed
always return unequal states.
- Function: make-random-state
- - Function: make-random-state OBJ
+ - 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
@@ -4933,43 +5321,43 @@ from sequential bytes, tests fail. With the seed
procedures for generating inexact distributions.
- Function: random:uniform
- - Function: random:uniform STATE
+ - 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
+ - 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
+ - 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
+ - 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
+ - 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.
- - Function: random:solid-sphere! VECT
- - Function: random:solid-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.
-

File: slib.info, Node: Fast Fourier Transform, Next: Cyclic Checksum, Prev: Random Numbers, Up: Mathematical Packages
@@ -4978,12 +5366,12 @@ Fast Fourier Transform
`(require 'fft)'
- - Function: fft ARRAY
+ - 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
+ - Function: fft-1 array
`fft-1' returns an array of complex numbers comprising the inverse
Discrete Fourier Transform of ARRAY.
@@ -5008,8 +5396,7 @@ Cyclic Checksum
`(require 'make-crc)'
- Function: make-port-crc
- - Function: make-port-crc DEGREE
- - Function: make-port-crc DEGREE GENERATOR
+ - 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.
@@ -5018,6 +5405,12 @@ Cyclic Checksum
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
@@ -5041,7 +5434,7 @@ Cyclic Checksum
(define (file-check-sum file) (call-with-input-file file crc32))
(file-check-sum (in-vicinity (library-vicinity) "ratize.scm"))
- => 3553047446
+ => 157103930

File: slib.info, Node: Plotting, Next: Root Finding, Prev: Cyclic Checksum, Up: Mathematical Packages
@@ -5061,7 +5454,7 @@ Plotting on Character Devices
- Variable: charplot:width
The number of columns to make the plot horizontally.
- - Procedure: plot! COORDS X-LABEL Y-LABEL
+ - 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.
@@ -5082,33 +5475,39 @@ Plotting on Character Devices
| |
1|- **** |
| ** ** |
- 750.0e-3|- * * |
+ 0.75|- * * |
| * * |
- 500.0e-3|- * * |
+ 0.5|- * * |
| * |
- 250.0e-3|- * |
+ 0.25|- * |
| * * |
0|-------------------*--------------------------|
| * |
- -250.0e-3|- * * |
+ -0.25|- * * |
| * * |
- -500.0e-3|- * |
+ -0.5|- * |
| * * |
- -750.0e-3|- * * |
+ -0.75|- * * |
| ** ** |
-1|- **** |
|____________:_____._____:_____._____:_________|
- x 2 4
+ x 2 4 6
+
+ - Procedure: plot-function! func x1 x2
+ - Procedure: plot-function! func x1 x2 npts
+ Plots the function of one argument FUNC over the range X1 to X2.
+ If the optional integer argument NPTS is supplied, it specifies
+ the number of points to evaluate FUNC at.

-File: slib.info, Node: Root Finding, Next: Commutative Rings, Prev: Plotting, Up: Mathematical Packages
+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
+ - 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
@@ -5125,11 +5524,11 @@ Root Finding
(integer-sqrt 15) => 4
- - Function: integer-sqrt Y
+ - 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
+ - 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))
@@ -5146,7 +5545,7 @@ Polynomials', IEEE Transactions on Circuits and Systems, Vol. 36, No.
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
+ - 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
@@ -5157,7 +5556,7 @@ Polynomials', IEEE Transactions on Circuits and Systems, Vol. 36, No.
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
+ - 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
@@ -5169,8 +5568,8 @@ Polynomials', IEEE Transactions on Circuits and Systems, Vol. 36, No.
`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
+ - 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.
@@ -5196,7 +5595,54 @@ Polynomials', IEEE Transactions on Circuits and Systems, Vol. 36, No.
non-false if the iteration should be stopped.

-File: slib.info, Node: Commutative Rings, Next: Determinant, Prev: Root Finding, Up: Mathematical Packages
+File: slib.info, Node: Minimizing, Next: Commutative Rings, Prev: Root Finding, Up: Mathematical Packages
+
+Minimizing
+==========
+
+ `(require 'minimize)'
+
+The Golden Section Search (1) algorithm finds minima of functions which
+are expensive to compute or for which derivatives are not available.
+Although optimum for the general case, convergence is slow, requiring
+nearly 100 iterations for the example (x^3-2x-5).
+
+If the derivative is available, Newton-Raphson is probably a better
+choice. If the function is inexpensive to compute, consider
+approximating the derivative.
+
+ - Function: golden-section-search f x0 x1 prec
+ X_0 are X_1 real numbers. The (single argument) procedure F is
+ unimodal over the open interval (X_0, X_1). That is, there is
+ exactly one point in the interval for which the derivative of F is
+ zero.
+
+ `golden-section-search' returns a pair (X . F(X)) where F(X) is
+ the minimum. The PREC parameter is the stop criterion. If PREC
+ is a positive number, then the iteration continues until X is
+ within PREC from the true value. If PREC is a negative integer,
+ then the procedure will iterate -PREC times or until convergence.
+ If PREC is a procedure of seven arguments, X0, X1, A, B, FA, FB,
+ and COUNT, then the iterations will stop when the procedure
+ returns `#t'.
+
+ Analytically, the minimum of x^3-2x-5 is 0.816497.
+ (define func (lambda (x) (+ (* x (+ (* x x) -2)) -5)))
+ (golden-section-search func 0 1 (/ 10000))
+ ==> (816.4883855245578e-3 . -6.0886621077391165)
+ (golden-section-search func 0 1 -5)
+ ==> (819.6601125010515e-3 . -6.088637561916407)
+ (golden-section-search func 0 1
+ (lambda (a b c d e f g ) (= g 500)))
+ ==> (816.4965933140557e-3 . -6.088662107903635)
+
+ ---------- Footnotes ----------
+
+ (1) David Kahaner, Cleve Moler, and Stephen Nash `Numerical Methods
+and Software' Prentice-Hall, 1989, ISBN 0-13-627258-4
+
+
+File: slib.info, Node: Commutative Rings, Next: Determinant, Prev: Minimizing, Up: Mathematical Packages
Commutative Rings
=================
@@ -5276,16 +5722,16 @@ through the use of "rulesets".
time `cring:define-rule' is called. If *RULESET* is `#f', then no
rules apply.
- - Function: make-ruleset RULE1 ...
- - Function: make-ruleset NAME RULE1 ...
+ - 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 ...
+ - 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
@@ -5310,14 +5756,14 @@ 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
+ - 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
+ - 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
@@ -5367,7 +5813,7 @@ be the same symbol whose top-level value is the procedure to create it.
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.
+have _not_ been defined are not changed.
(define (n*n ni nj)
(let ((list1 (cdr ni)) (list2 (cdr nj)))
@@ -5480,10 +5926,13 @@ File: slib.info, Node: Determinant, Prev: Commutative Rings, Up: Mathematical
Determinant
===========
- (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
+ - Function: determinant square-matrix
+ Returns the determinant of SQUARE-MATRIX.
+
+ (require 'determinant)
+ (determinant '((1 2) (3 4))) => -2
+ (determinant '((1 2 3) (4 5 6) (7 8 9))) => 0
+ (determinant '((1 2 3 4) (5 6 7 8) (9 10 11 12))) => 0

File: slib.info, Node: Database Packages, Next: Other Packages, Prev: Mathematical Packages, Up: Top
@@ -5529,7 +5978,7 @@ otherwise. For example:
(define foo (alist-table 'foo))
foo => #f
- - Function: make-base FILENAME KEY-DIMENSION COLUMN-TYPES
+ - 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
@@ -5543,7 +5992,7 @@ otherwise. For example:
`#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
+ - 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
@@ -5553,7 +6002,7 @@ otherwise. For example:
Calling the `close-base' (and possibly other) method on a MUTABLE?
database will cause FILENAME to be written to.
- - Function: write-base LLDB FILENAME
+ - 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
@@ -5563,20 +6012,20 @@ otherwise. For example:
underlying base table implelentation. If the operations completed
successfully, `#t' is returned. Otherwise, `#f' is returned.
- - Function: sync-base LLDB
+ - 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
+ - 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
+ - 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
@@ -5588,7 +6037,7 @@ otherwise. For example:
`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
+ - 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'.
@@ -5597,11 +6046,11 @@ otherwise. For example:
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
+ - 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
+ - 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
@@ -5611,7 +6060,7 @@ otherwise. For example:
function which are not `equal?' must result in returned values
which are not `equal?'.
- - Function: make-list-keyifier KEY-DIMENSION TYPES
+ - 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
@@ -5624,26 +6073,26 @@ otherwise. For example:
which are not `equal?' must result in returned values which are not
`equal?'.
- - Function: make-key-extractor KEY-DIMENSION TYPES COLUMN-NUMBER
+ - 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
+ - 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.
+be the value returned by a call to a _keyify_ routine.
-In contrast, a MATCH-KEY argument is a list of length equal to the
-number of primary keys. The MATCH-KEY restricts the actions of the
+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-KEY list. The elements and their
+corresponding element of the MATCH-KEYS list. The elements and their
actions are:
`#f'
@@ -5658,53 +6107,59 @@ actions are:
other values
Any other value matches only those keys `equal?' to it.
- - Function: for-each-key HANDLE PROCEDURE MATCH-KEY
+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 satisfies MATCH-KEY in an unspecified order. An unspecified
+ which satisfy MATCH-KEYS in an unspecified order. An unspecified
value is returned.
- - Function: map-key HANDLE PROCEDURE MATCH-KEY
+ - 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 satisfies
- MATCH-KEY in an unspecified order.
+ with each KEY in the table opened in HANDLE which satisfy
+ MATCH-KEYS in an unspecified order.
- - Function: ordered-for-each-key HANDLE PROCEDURE MATCH-KEY
+ - 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 satisfies MATCH-KEY in the natural order for the types of
- the primary key fields of that table. An unspecified value is
+ 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 MATCH-KEY
- Removes all rows which satisfy MATCH-KEY from the table opened in
+ - 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
+ - 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
+ - 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
+ - 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
+ - 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
+ - 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
+ - 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'.
@@ -5781,7 +6236,7 @@ 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*
+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,
@@ -5856,7 +6311,7 @@ File: slib.info, Node: Creating and Opening Relational Databases, Next: Relati
Creating and Opening Relational Databases
-----------------------------------------
- - Function: make-relational-system BASE-TABLE-IMPLEMENTATION
+ - Function: make-relational-system base-table-implementation
Returns a procedure implementing a relational database using the
BASE-TABLE-IMPLEMENTATION.
@@ -5879,7 +6334,7 @@ Creating and Opening Relational Databases
What follows are the descriptions of the methods available from
relational system returned by a call to `make-relational-system'.
- - Function: create-database FILENAME
+ - 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
@@ -5890,7 +6345,7 @@ relational system returned by a call to `make-relational-system'.
`#f' is returned. For the fields and layout of descriptor tables,
*Note Catalog Representation::
- - Function: open-database FILENAME MUTABLE?
+ - 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
@@ -5920,7 +6375,7 @@ the database with the symbol name of the operation. For example:
to this database will signal an error. If the operations completed
successfully, `#t' is returned. Otherwise, `#f' is returned.
- - Function: write-database FILENAME
+ - 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
@@ -5931,29 +6386,34 @@ the database with the symbol name of the operation. For example:
completed successfully, `#t' is returned. Otherwise, `#f' is
returned.
- - Function: table-exists? TABLE-NAME
+ - 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?
+ - 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
+ - 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
+ - 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
+ - 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'.
@@ -5998,7 +6458,7 @@ 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
+ - 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
@@ -6007,7 +6467,7 @@ missing.
((plat 'get 'processor) 'djgpp) => i386
((plat 'get 'processor) 'be-os) => #f
- - Function: get* COLUMN-NAME
+ - 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
@@ -6108,7 +6568,7 @@ missing.
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
+ _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
@@ -6189,7 +6649,7 @@ 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*
+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!
@@ -6270,7 +6730,7 @@ Process scope
implementations.
Shared utilities with state
- Some shared utilities have state which should *not* be part of a
+ 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
@@ -6309,13 +6769,13 @@ Also included are utilities which provide:
for any SLIB relational database.
- - Function: create-database FILENAME BASE-TABLE-TYPE
+ - 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
+ - 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,
@@ -6323,9 +6783,9 @@ for any SLIB relational database.
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 ...
+ - 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):
@@ -6377,7 +6837,7 @@ following fields:
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*
+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
@@ -6393,10 +6853,10 @@ 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.
+`*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
@@ -6405,7 +6865,7 @@ 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
+ - 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
@@ -6452,7 +6912,7 @@ accessible to code in the `*commands*' table.
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::.).
+arguments from a `getopt' style argument list (*note Getopt::).
(require 'database-utilities)
(require 'fluid-let)
@@ -6559,7 +7019,7 @@ arguments from a `getopt' style argument list (*note Getopt::.).
Some commands are defined in all extended relational-databases. The
are called just like *Note Relational Database Operations::.
- - Function: add-domain DOMAIN-ROW
+ - 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'.
@@ -6588,17 +7048,17 @@ are called just like *Note Relational Database Operations::.
(filename #f #f string #f)
(build-whats #f #f symbol #f)))
- - Function: delete-domain DOMAIN-NAME
+ - Function: delete-domain domain-name
Removes and returns the DOMAIN-NAME row from the "domains" table.
- - Function: domain-checker DOMAIN
+ - Function: domain-checker domain
Returns a procedure to check an argument for conformance to domain
DOMAIN.
Defining Tables
...............
- - Procedure: define-tables RDB SPEC-0 ...
+ - Procedure: define-tables rdb spec-0 ...
Adds tables as specified in SPEC-0 ... to the open
relational-database RDB. Each SPEC has the form:
@@ -6691,6 +7151,18 @@ when the database is opened. The database is then closed and reopened.
-|
Welcome
+Listing Tables
+..............
+
+ - Procedure: list-table-definition rdb table-name
+ If symbol TABLE-NAME exists in the open relational-database RDB,
+ then returns a list of the table-name, its primary key names and
+ domains, its other key names and domains, and the table's records
+ (as lists). Otherwise, returns #f.
+
+ The list returned by `list-table-definition', when passed as an
+ argument to `define-tables', will recreate the table.
+

File: slib.info, Node: Database Reports, Next: Database Browser, Prev: Database Utilities, Up: Relational Database
@@ -6702,8 +7174,8 @@ 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
+ - 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:
@@ -6721,7 +7193,7 @@ truncating fields. `report.scm' needs to be rewritten using `printf'.
The report is prepared as follows:
- * `Format' (*note Format::.) is called with the `header' field
+ * `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
@@ -6779,26 +7251,26 @@ Database Browser
(require 'database-browse)
- - Procedure: browse DATABASE
+ - 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
+ - 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
+ - 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
+ - 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
+ - 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.
@@ -6832,7 +7304,7 @@ other data structures for large aggregates:
* 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
+ * 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
@@ -6840,13 +7312,14 @@ other data structures for large aggregates:
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.
+ 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
@@ -6894,7 +7367,7 @@ 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
+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
@@ -6904,7 +7377,7 @@ 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<?
+ - 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':
@@ -6936,21 +7409,21 @@ used many times throughout the program's execution.
(define string-wt-type (make-wt-tree-type string<?))
- - procedure+: make-wt-tree WT-TREE-TYPE
+ - 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
+ - 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
+ - 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:
@@ -6974,19 +7447,19 @@ 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
+ - procedure+: wt-tree? object
Returns `#t' if OBJECT is a weight-balanced tree, otherwise
returns `#f'.
- - procedure+: wt-tree/empty? WT-TREE
+ - procedure+: wt-tree/empty? wt-tree
Returns `#t' if WT-TREE contains no associations, otherwise
returns `#f'.
- - procedure+: wt-tree/size WT-TREE
+ - 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
+ - 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
@@ -6994,34 +7467,34 @@ number of associations in a tree.
proportional to the logarithm of the number of associations in
WT-TREE.
- - procedure+: wt-tree/add! WT-TREE KEY DATUM
+ - 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
+ - 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
+ - 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
+ - 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
+ - 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
@@ -7033,25 +7506,25 @@ File: slib.info, Node: Advanced Operations on Weight-Balanced Trees, Next: Ind
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
+ 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
+ - 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
+ - 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
+ - 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
@@ -7064,7 +7537,7 @@ associations.
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
+ - 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
@@ -7075,9 +7548,9 @@ associations.
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
+ - 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
+ 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
@@ -7085,7 +7558,7 @@ associations.
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
+ - 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
@@ -7100,9 +7573,9 @@ associations.
required by this operation is proportional to the size of
WT-TREE-1.
- - procedure+: wt-tree/set-equal? WT-TREE-1 WT-TREE-2
+ - 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*.
+ 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
@@ -7117,7 +7590,7 @@ associations.
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
+ - 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
@@ -7138,7 +7611,7 @@ associations.
0
WT-TREE)
- - procedure+: wt-tree/for-each ACTION 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
@@ -7162,9 +7635,9 @@ 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
+ - 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'
@@ -7187,7 +7660,7 @@ determined, both in logarthmic time.
maximum: (wt-tree/index WT-TREE
(-1+ (wt-tree/size WT-TREE)))
- - procedure+: wt-tree/rank WT-TREE KEY
+ - 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
@@ -7195,9 +7668,9 @@ determined, both in logarthmic time.
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
+ - 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
@@ -7212,7 +7685,7 @@ determined, both in logarthmic time.
(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
+ - 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.
@@ -7222,7 +7695,7 @@ determined, both in logarthmic time.
(wt-tree/delete WT-TREE (wt-tree/min WT-TREE))
- - procedure+: wt-tree/delete-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
@@ -7240,14 +7713,15 @@ Other Packages
* Menu:
* Data Structures:: Various data structures.
+* Sorting and Searching:: |
* Procedures:: Miscellaneous utility procedures.
* Standards Support:: Support for Scheme Standards.
* Session Support:: REPL and Debugging.
* Extra-SLIB Packages::

-File: slib.info, Node: Data Structures, Next: Procedures, Prev: Other Packages, Up: Other Packages
-
+File: slib.info, Node: Data Structures, Next: Sorting and Searching, Prev: Other Packages, Up: Other Packages
+ |
Data Structures
===============
@@ -7257,6 +7731,7 @@ Data Structures
* Array Mapping:: 'array-for-each
* Association Lists:: 'alist
* Byte:: 'byte
+* Portable Image Files:: 'pnm
* Collections:: 'collect
* Dynamic Data Type:: 'dynamic
* Hash Tables:: 'hash-table
@@ -7264,8 +7739,7 @@ Data Structures
* Object:: 'object
* Priority Queues:: 'priority-queue
* Queues:: 'queue
-* Records:: 'record
-* Structures:: 'struct, 'structure
+* Records:: 'record |

File: slib.info, Node: Arrays, Next: Array Mapping, Prev: Data Structures, Up: Data Structures
@@ -7275,24 +7749,40 @@ Arrays
`(require 'array)'
- - Function: array? OBJ
+ - 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.
+_Note:_ Arrays are not disjoint from other Scheme types. Strings and |
+vectors also satisfy `array?'. A disjoint array predicate can be |
+written: |
+ |
+ (define (strict-array? obj) |
+ (and (array? obj) (not (string? obj)) (not (vector? obj)))) |
+ |
+ - Function: array=? array1 array2 |
+ Returns `#t' if ARRAY1 and ARRAY2 have the same rank and shape and |
+ the corresponding elements of ARRAY1 and ARRAY2 are `equal?'. |
+ |
+ (array=? (make-array 'foo 3 3) (make-array 'foo '(0 2) '(1 2))) |
+ => #t |
+ |
+ - Function: make-array initial-value bound1 bound2 ...
+ Creates and returns an array with dimensions BOUND1, BOUND2, ... |
+ and filled with INITIAL-VALUE. |
- When constructing an array, BOUND is either an inclusive range of
+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 ...
+ - 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))
@@ -7305,44 +7795,32 @@ a single integer. So
(array-ref freds-center 0 0)
=> FOO
- - Function: array-rank OBJ
+ - 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:
+ - Function: array-shape array
+ Returns a list of inclusive bounds. |
+ |
(array-shape (make-array 'foo 3 5))
=> ((0 2) (0 4))
- - Function: array-dimensions ARRAY
+ - 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:
+ elements with a 0 minimum with one greater than the maximum. |
+ |
(array-dimensions (make-array 'foo 3 5))
=> (3 5)
- - Procedure: array-in-bounds? ARRAY INDEX1 INDEX2 ...
+ - Function: 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
+ - Function: array-ref array index1 index2 ...
+ Returns the (INDEX1, INDEX2, ...) element of ARRAY. |
- - 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.
+ - Function: array-set! array obj index1 index2 ... |
+ Stores OBJ in the (INDEX1, INDEX2, ...) element of ARRAY. The |
+ value returned by `array-set!' is unspecified. |

File: slib.info, Node: Array Mapping, Next: Association Lists, Prev: Arrays, Up: Data Structures
@@ -7352,7 +7830,7 @@ Array Mapping
`(require 'array-for-each)'
- - Function: array-map! ARRAY0 PROC ARRAY1 ...
+ - 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
@@ -7369,7 +7847,7 @@ Array Mapping
a list of indexes for which ARRAY is defined, (equal? LI (apply
array-ref (array-indexes ARRAY) LI)).
- - Function: array-index-map! ARRAY PROC
+ - 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.
@@ -7385,7 +7863,7 @@ Array Mapping
(array-index-map! v (lambda (i) i))
v))
- - Function: array-copy! SOURCE DESTINATION
+ - 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.
@@ -7407,18 +7885,18 @@ symmetric, and transitive.
Alist functions can be used with a secondary index method such as hash
tables for improved performance.
- - Function: predicate->asso PRED
+ - 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
+ - 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
+ - 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
@@ -7428,7 +7906,7 @@ tables for improved performance.
(define alist '())
(set! alist (put alist "Foo" 9))
- - Function: alist-remover PRED
+ - 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
@@ -7436,17 +7914,17 @@ tables for improved performance.
(define rem (alist-remover string-ci=?))
(set! alist (rem alist "foo"))
- - Function: alist-map PROC ALIST
+ - 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
+ - Function: alist-for-each proc alist
Applies PROC to each pair of keys and values of ALIST. PROC must
be a function of 2 arguments. The returned value is unspecified.

-File: slib.info, Node: Byte, Next: Collections, Prev: Association Lists, Up: Data Structures
+File: slib.info, Node: Byte, Next: Portable Image Files, Prev: Association Lists, Up: Data Structures
Byte
----
@@ -7458,28 +7936,28 @@ 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
+ - 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
+ - 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
+ - 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
+ - Function: bytes-length bytes
`bytes-length' returns length of byte-array BYTES.
- - Function: write-byte BYTE
- - Function: write-byte BYTE PORT
+ - 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
@@ -7487,7 +7965,7 @@ character sets. These functions abstract the notion of a "byte".
- Function: read-byte
- - Function: read-byte PORT
+ - 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
@@ -7495,12 +7973,12 @@ character sets. These functions abstract the notion of a "byte".
`current-input-port'.
- - Function: bytes BYTE ...
+ - Function: bytes byte ...
Returns a newly allocated byte-array composed of the arguments.
- - Function: bytes->list BYTES
- - Function: list->bytes BYTES
+ - 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
@@ -7509,7 +7987,58 @@ character sets. These functions abstract the notion of a "byte".

-File: slib.info, Node: Collections, Next: Dynamic Data Type, Prev: Byte, Up: Data Structures
+File: slib.info, Node: Portable Image Files, Next: Collections, Prev: Byte, Up: Data Structures
+
+Portable Image Files
+--------------------
+
+ `(require 'pnm)'
+
+ - Function: pnm:type-dimensions path
+ The string PATH must name a "portable bitmap graphics" file.
+ `pnm:type-dimensions' returns a list of 4 items:
+ 1. A symbol describing the type of the file named by PATH.
+
+ 2. The image width in pixels.
+
+ 3. The image height in pixels.
+
+ 4. The maximum value of pixels assume in the file.
+
+ The current set of file-type symbols is:
+ pbm
+ pbm-raw
+ Black-and-White image; pixel values are 0 or 1.
+
+ pgm
+ pgm-raw
+ Gray (monochrome) image; pixel values are from 0 to MAXVAL
+ specified in file header.
+
+ ppm
+ ppm-raw
+ RGB (full color) image; red, green, and blue interleaved
+ pixel values are from 0 to MAXVAL
+
+
+ - Function: pnm:image-file->array path array
+ Reads the "portable bitmap graphics" file named by PATH into
+ ARRAY. ARRAY must be the correct size and type for PATH. ARRAY
+ is returned.
+
+ - Function: pnm:image-file->array path
+ `pnm:image-file->array' creates and returns an array with the
+ "portable bitmap graphics" file named by PATH read into it.
+
+
+ - Procedure: pnm:array-write type array maxval path
+ Writes the contents of ARRAY to a TYPE image file named PATH. The
+ file will have pixel values between 0 and MAXVAL, which must be
+ compatible with TYPE. For `pbm' files, MAXVAL must be `1'.
+
+
+
+File: slib.info, Node: Collections, Next: Dynamic Data Type, Prev: Portable Image Files, Up: Data Structures
Collections
-----------
@@ -7523,7 +8052,7 @@ Dylan(TM) language, but with a different interface. They have
implicit (as with lists).
New types of collections may be defined as YASOS objects (*note
-Yasos::.). They must support the following operations:
+Yasos::). They must support the following operations:
* `(collection? SELF)' (always returns `#t');
* `(size SELF)' returns the number of elements in the collection;
@@ -7542,12 +8071,12 @@ Yasos::.). They must support the following operations:
They might support specialized `for-each-key' and `for-each-elt'
operations.
- - Function: collection? OBJ
+ - 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
+ - Procedure: map-elts proc collection1 ... |
+ - Procedure: do-elts proc collection1 ... |
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
@@ -7562,26 +8091,26 @@ operations.
(map-elts + (list 1 2 3) (vector 1 2 3))
=> #(2 4 6)
- - Procedure: map-keys PROC . COLLECTIONS
- - Procedure: do-keys PROC . COLLECTIONS
+ - Procedure: map-keys proc collection1 ... |
+ - Procedure: do-keys proc collection1 ... |
These are analogous to `map-elts' and `do-elts', but each
- iteration is over the COLLECTIONS' *keys* rather than their
+ 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
+ - 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
+ - Function: reduce proc seed collection1 ... |
A generalization of the list-based `comlist:reduce-init' (*note
- Lists as sequences::.) to collections which will shadow the
+ Lists as sequences::) to collections which will shadow the
list-based version if `(require 'collect)' follows `(require
- 'common-list-functions)' (*note Common List Functions::.).
+ 'common-list-functions)' (*note Common List Functions::).
Examples:
(reduce + 0 (vector 1 2 3))
@@ -7589,31 +8118,31 @@ operations.
(reduce union '() '((a b c) (b c d) (d a)))
=> (c b d a).
- - Function: any? PRED . COLLECTIONS
+ - Function: any? pred collection1 ... |
A generalization of the list-based `some' (*note Lists as
- sequences::.) to collections.
+ sequences::) to collections.
Example:
(any? odd? (list 2 3 4 5))
=> #t
- - Function: every? PRED . COLLECTIONS
+ - Function: every? pred collection1 ... |
A generalization of the list-based `every' (*note Lists as
- sequences::.) to collections.
+ sequences::) to collections.
Example:
(every? collection? '((1 2) #(1 2)))
=> #t
- - Function: empty? COLLECTION
+ - Function: empty? collection
Returns `#t' iff there are no elements in COLLECTION.
`(empty? COLLECTION) == (zero? (size COLLECTION))'
- - Function: size COLLECTION
+ - Function: size collection
Returns the number of elements in COLLECTION.
- - Function: Setter LIST-REF
+ - 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.
@@ -7685,23 +8214,23 @@ Dynamic Data Type
`(require 'dynamic)'
- - Function: make-dynamic OBJ
+ - Function: make-dynamic obj
Create and returns a new "dynamic" whose global value is OBJ.
- - Function: dynamic? 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
+ - Function: dynamic-ref dyn
Return the value of the given dynamic in the current dynamic
environment.
- - Procedure: dynamic-set! DYN OBJ
+ - 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
+ - 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
@@ -7720,7 +8249,7 @@ Hash Tables
`(require 'hash-table)'
- - Function: predicate->hash PRED
+ - 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
@@ -7728,7 +8257,7 @@ Hash Tables
A hash table is a vector of association lists.
- - Function: make-hash-table K
+ - Function: make-hash-table k
Returns a vector of K empty (association) lists.
Hash table functions provide utilities for an associative database.
@@ -7736,33 +8265,33 @@ 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
+ - 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-inquirer pred
+ Returns a procedure of 2 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
+ - 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
+ - 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
+ - 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
+ - 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.
@@ -7778,9 +8307,9 @@ Hashing
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
+ - 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.
@@ -7800,9 +8329,9 @@ Hash tables use these functions.
`(require 'sierpinski)'
- - Function: make-sierpinski-indexer MAX-COORDINATE
+ - 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.
+ 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
@@ -7823,11 +8352,11 @@ Hash tables use these functions.
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.
+ 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,
+ _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.
@@ -7846,15 +8375,15 @@ Hash tables use these functions.
`(require 'soundex)'
- - Function: soundex NAME
- Computes the *soundex* hash of NAME. Returns a string of an
+ - Function: soundex name
+ Computes the _soundex_ hash of NAME. Returns a string of an
initial letter and up to three digits between 0 and 6. Soundex
supposedly has the property that names that sound similar in normal
English pronunciation tend to map to the same key.
Soundex was a classic algorithm used for manual filing of personal
records before the advent of computers. It performs adequately for
- English names but has trouble with other nationalities.
+ English names but has trouble with other languages.
See Knuth, Vol. 3 `Sorting and searching', pp 391-2
@@ -7927,7 +8456,7 @@ PREDICATE
Procedures
----------
- - Function: make-object ANCESTOR ...
+ - 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
@@ -7935,10 +8464,10 @@ Procedures
In this case the method of the ANCESTOR first appearing in the
list is the one returned by `get-method'.
- - Function: object? OBJ
+ - Function: object? obj
Returns boolean value whether OBJ was created by make-object.
- - Function: make-generic-method EXCEPTION-PROCEDURE
+ - 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.
@@ -7946,20 +8475,20 @@ Procedures
- Function: make-generic-predicate
Returns a boolean procedure for any scheme object.
- - Function: make-method! OBJECT GENERIC-METHOD METHOD
+ - 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
+ 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
+ - Function: make-predicate! object generic-preciate
Makes a predicate method associated with the GENERIC-PREDICATE.
- - Function: unmake-method! OBJECT GENERIC-METHOD
+ - Function: unmake-method! object generic-method
Removes an object's association with a GENERIC-METHOD .
- - Function: get-method OBJECT 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.
@@ -8116,18 +8645,18 @@ Priority Queues
`(require 'priority-queue)'
- - Function: make-heap PRED<?
+ - Function: make-heap pred<?
Returns a binary heap suitable which can be used for priority queue
operations.
- - Function: heap-length HEAP
+ - Function: heap-length heap
Returns the number of elements in HEAP.
- - Procedure: heap-insert! HEAP ITEM
+ - 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
+ - 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.
@@ -8150,35 +8679,35 @@ rear, and removed from the front (i.e., they are what are often called
- Function: make-queue
Returns a new, empty queue.
- - Function: queue? OBJ
+ - Function: queue? obj
Returns `#t' if OBJ is a queue.
- - Function: queue-empty? Q
+ - Function: queue-empty? q
Returns `#t' if the queue Q is empty.
- - Procedure: queue-push! Q DATUM
+ - Procedure: queue-push! q datum
Adds DATUM to the front of queue Q.
- - Procedure: enquque! Q DATUM
+ - 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
+ - Function: queue-front q
Returns the datum at the front of the queue Q.
- - Function: queue-rear Q
+ - Function: queue-rear q
Returns the datum at the rear of the queue Q.
- - Prcoedure: queue-pop! Q
- - Procedure: dequeue! Q
+ - Prcoedure: queue-pop! q
+ - Procedure: dequeue! q
Both of these procedures remove and return the datum at the front
of the queue. `queue-pop!' is used to suggest that the queue is
being used like a stack.

-File: slib.info, Node: Records, Next: Structures, Prev: Queues, Up: Data Structures
-
+File: slib.info, Node: Records, Prev: Queues, Up: Data Structures
+ |
Records
-------
@@ -8187,7 +8716,7 @@ Records
The Record package provides a facility for user to define their own
record data types.
- - Function: make-record-type TYPE-NAME FIELD-NAMES
+ - 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
@@ -8197,7 +8726,7 @@ record data types.
duplicates. It is unspecified how record-type descriptors are
represented.
- - Function: record-constructor RTD [FIELD-NAMES]
+ - 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,
@@ -8210,13 +8739,13 @@ record data types.
it is an error if it contains any duplicates or any symbols not in
the default list.
- - Function: record-predicate RTD
+ - 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
+ - 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
@@ -8225,7 +8754,7 @@ record data types.
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
+ - 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
@@ -8249,81 +8778,24 @@ types which are unforgeable and incorruptible by R4RS procedures.
supported.

-File: slib.info, Node: Structures, Prev: Records, Up: Data Structures
-
-Structures
-----------
-
- `(require 'struct)' (uses defmacros)
-
- `defmacro's which implement "records" from the book `Essentials of
-Programming Languages' by Daniel P. Friedman, M. Wand and C.T. Haynes.
-Copyright 1992 Jeff Alexander, Shinnder Lee, and Lewis Patterson
-
- Matthew McDonald <mafm@cs.uwa.edu.au> added field setters.
-
- - Macro: define-record TAG (VAR1 VAR2 ...)
- Defines several functions pertaining to record-name TAG:
-
- - Function: make-TAG VAR1 VAR2 ...
-
- - Function: TAG? OBJ
-
- - Function: TAG->VAR1 OBJ
-
- - Function: TAG->VAR2 OBJ
- ...
-
- - Function: set-TAG-VAR1! OBJ VAL
-
- - Function: set-TAG-VAR2! OBJ VAL
- ...
-
- Here is an example of its use.
-
- (define-record term (operator left right))
- => #<unspecified>
- (define foo (make-term 'plus 1 2))
- => foo
- (term->left foo)
- => 1
- (set-term-left! foo 2345)
- => #<unspecified>
- (term->left foo)
- => 2345
-
- - Macro: variant-case EXP (TAG (VAR1 VAR2 ...) BODY) ...
- executes the following for the matching clause:
-
- ((lambda (VAR1 VAR ...) BODY)
- (TAG->VAR1 EXP)
- (TAG->VAR2 EXP) ...)
-
-
-File: slib.info, Node: Procedures, Next: Standards Support, Prev: Data Structures, Up: Other Packages
-
-Procedures
-==========
-
- Anything that doesn't fall neatly into any of the other categories
-winds up here.
+File: slib.info, Node: Sorting and Searching, Next: Procedures, Prev: Data Structures, Up: Other Packages
+ |
+Sorting and Searching |
+===================== |
* Menu:
* Common List Functions:: 'common-list-functions
-* Tree Operations:: 'tree
+* Tree Operations:: 'tree |
* Chapter Ordering:: 'chapter-order
* Sorting:: 'sort
-* Topological Sort:: Keep your socks on.
-* String-Case:: 'string-case
-* String Ports:: 'string-port
+* Topological Sort:: Keep your socks on. |
* String Search:: Also Search from a Port.
-* Line I/O:: 'line-i/o
-* Multi-Processing:: 'process
+* Sequence Comparison:: 'diff and longest-common-subsequence |

-File: slib.info, Node: Common List Functions, Next: Tree Operations, Prev: Procedures, Up: Procedures
-
+File: slib.info, Node: Common List Functions, Next: Tree Operations, Prev: Sorting and Searching, Up: Sorting and Searching
+ |
Common List Functions
---------------------
@@ -8346,7 +8818,8 @@ File: slib.info, Node: List construction, Next: Lists as sets, Prev: Common L
List construction
.................
- - Function: make-list K . INIT
+ - Function: make-list k |
+ - 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.
@@ -8356,7 +8829,7 @@ List construction
(make-list 5 'foo)
=> (foo foo foo foo foo)
- - Function: list* X . Y
+ - Function: list* obj1 obj2 ... |
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.:
@@ -8369,7 +8842,7 @@ List construction
(list* ARGS '())
== (list ARGS)
- - Function: copy-list LST
+ - 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
@@ -8401,7 +8874,7 @@ Lists as sets
`eqv?' is used to test for membership by procedures which treat lists
as sets.
- - Function: adjoin E L
+ - 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)'.
@@ -8412,37 +8885,36 @@ as sets.
(adjoin 'foo '(bar baz bang))
=> (foo bar baz bang)
- - Function: union L1 L2
+ - 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)
+ => (8 7 6 5 1 2 3 4) |
(union '(1 2 3 4) '(3 4 5 6))
- => (2 1 3 4 5 6)
+ => (6 5 1 2 3 4) |
- - Function: intersection L1 L2
+ - Function: intersection l1 l2
`intersection' returns all elements that are in both L1 and L2.
Example:
(intersection '(1 2 3 4) '(3 4 5 6))
- => (3 4)
+ => (3 4) |
(intersection '(1 2 3 4) '(5 6 7 8))
=> ()
- - Function: set-difference L1 L2
- `set-difference' returns the union of all elements that are in L1
- but not in L2.
+ - 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))
- => (1 2)
+ => (1 2) |
(set-difference '(1 2 3 4) '(1 2 3 4 5 6))
=> ()
- - Function: member-if PRED LST
+ - 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.
@@ -8453,7 +8925,7 @@ as sets.
(member-if number? '(1 2 3 4))
=> (1 2 3 4)
- - Function: some PRED LST . MORE-LSTS
+ - Function: some pred lst1 lst2 ... |
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.
@@ -8471,7 +8943,7 @@ as sets.
(some > '(2 3) '(1 4))
=> #f
- - Function: every PRED LST . MORE-LSTS
+ - Function: every pred lst1 lst2 ... |
`every' is analogous to `some' except it returns `#t' if every
application of PRED is `#t' and `#f' otherwise.
@@ -8485,11 +8957,11 @@ as sets.
(every > '(2 3) '(1 4))
=> #f
- - Function: notany PRED . LST
+ - Function: notany pred lst1 ... |
`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
+ - Function: notevery pred lst1 ... |
`notevery' is analogous to `some' but returns `#t' as soon as an
application of PRED returns `#f', and `#f' otherwise.
@@ -8500,7 +8972,25 @@ as sets.
(notevery even? '(2 4 6 8))
=> #f
- - Function: find-if PRED LST
+ - 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.
@@ -8515,7 +9005,7 @@ as sets.
(find-if symbol? '(1 2 foo bar))
=> foo
- - Function: remove ELT LST
+ - 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
@@ -8523,12 +9013,12 @@ as sets.
Example:
(remove 1 '(1 2 1 3 1 4 1 5))
- => (2 3 4 5)
+ => (2 3 4 5) |
(remove 'foo '(bar baz bang))
- => (bar baz bang)
+ => (bar baz bang) |
- - Function: remove-if PRED LST
+ - Function: remove-if pred lst
`remove-if' removes all ELEMENTs from LST where `(PRED ELEMENT)'
is `#t' and returns everything that's left.
@@ -8537,9 +9027,9 @@ as sets.
=> ()
(remove-if even? '(1 2 3 4 5 6 7 8))
- => (1 3 5 7)
+ => (1 3 5 7) |
- - Function: remove-if-not PRED LST
+ - 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.
@@ -8547,9 +9037,9 @@ as sets.
(remove-if-not number? '(foo bar baz))
=> ()
(remove-if-not odd? '(1 2 3 4 5 6 7 8))
- => (1 3 5 7)
+ => (1 3 5 7) |
- - Function: has-duplicates? LST
+ - Function: has-duplicates? lst
returns `#t' if 2 members of LST are `equal?', `#f' otherwise.
Example:
@@ -8561,16 +9051,16 @@ as sets.
The procedure `remove-duplicates' uses `member' (rather than `memv').
- - Function: remove-duplicates LST
+ - 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)
+ => (1 2 3 4) |
(remove-duplicates '(2 4 3 4))
- => (3 4 2)
+ => (2 4 3) |

File: slib.info, Node: Lists as sequences, Next: Destructive list operations, Prev: Lists as sets, Up: Common List Functions
@@ -8578,7 +9068,7 @@ File: slib.info, Node: Lists as sequences, Next: Destructive list operations,
Lists as sequences
..................
- - Function: position OBJ LST
+ - Function: position obj lst
`position' returns the 0-based position of OBJ in LST, or `#f' if
OBJ does not occur in LST.
@@ -8590,13 +9080,13 @@ Lists as sequences
(position 'oops '(foo bar baz bang))
=> #f
- - Function: reduce P LST
+ - 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:reduce' (*note Collections::) provides a version of
`collect' generalized to collections.
Example:
@@ -8621,7 +9111,7 @@ Lists as sequences
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)
+ ;;; Contributed by Jussi Piitulainen (jpiitula @ ling.helsinki.fi)
(define commute
(lambda (f)
@@ -8632,7 +9122,7 @@ Lists as sequences
(lambda (args)
(reduce-init (commute cons) '() args)))
- - Function: reduce-init P INIT LST
+ - 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
@@ -8682,7 +9172,7 @@ Lists as sequences
== (insert (1 1 3 4) 5)
=> (1 1 3 4 5)
- - Function: last LST N
+ - Function: last lst n
`last' returns the last N elements of LST. N must be a
non-negative integer.
@@ -8692,7 +9182,7 @@ Lists as sequences
(last '(1 2 3) 0)
=> 0
- - Function: butlast LST N
+ - Function: butlast lst n
`butlast' returns all but the last N elements of LST.
Example:
@@ -8708,7 +9198,7 @@ arugments.
(butlast '(a b c d e) 2)
=> (a b c)
- - Function: nthcdr N LST
+ - Function: nthcdr n lst
`nthcdr' takes N `cdr's of LST and returns the result. Thus
`(nthcdr 3 LST)' == `(cdddr LST)'
@@ -8718,14 +9208,14 @@ arugments.
(nthcdr 0 '(a b c d))
=> (a b c d)
- - Function: butnthcdr N LST
+ - 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.
@@ -8743,10 +9233,10 @@ Destructive list operations
These procedures may mutate the list they operate on, but any such
mutation is undefined.
- - Procedure: nconc ARGS
+ - 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::.).
+ Sometimes called `append!' (*note Rev2 Procedures::).
Example: You want to find the subsets of a set. Here's the
obvious way:
@@ -8771,7 +9261,7 @@ mutation is undefined.
`nconc' is the same as `append!' in `sc2.scm'.
- - Procedure: nreverse LST
+ - Procedure: nreverse lst
`nreverse' reverses the order of elements in LST by mutating
`cdr's of the list. Sometimes called `reverse!'.
@@ -8791,9 +9281,9 @@ mutation is undefined.
(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
+ - 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:
@@ -8824,7 +9314,7 @@ File: slib.info, Node: Non-List functions, Prev: Destructive list operations,
Non-List functions
..................
- - Function: and? . ARGS
+ - Function: and? arg1 ... |
`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
@@ -8836,7 +9326,7 @@ Non-List functions
(and #f 1 2)
=> #f
- - Function: or? . ARGS
+ - Function: or? arg1 ... |
`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'.)
@@ -8847,7 +9337,7 @@ Non-List functions
(or? #f #f #f)
=> #f
- - Function: atom? OBJECT
+ - Function: atom? object
Returns `#t' if OBJECT is not a pair and `#f' if it is pair.
(Called `atom' in Common LISP.)
(atom? 1)
@@ -8857,17 +9347,9 @@ Non-List functions
(atom? #(1 2)) ; dubious!
=> #t
- - Function: type-of OBJECT
- Returns a symbol name for the type of OBJECT.
-
- - Function: coerce OBJECT RESULT-TYPE
- Converts and returns OBJECT of type `char', `number', `string',
- `symbol', `list', or `vector' to RESULT-TYPE (which must be one of
- these symbols).
-

-File: slib.info, Node: Tree Operations, Next: Chapter Ordering, Prev: Common List Functions, Up: Procedures
-
+File: slib.info, Node: Tree Operations, Next: Chapter Ordering, Prev: Common List Functions, Up: Sorting and Searching
+ |
Tree operations
---------------
@@ -8875,16 +9357,18 @@ Tree operations
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
+ - Function: subst new old tree
+ - Function: subst new old tree equ? |
+ - 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.
+ `eq?' and `eqv?' respectively. If `subst' is called with a fourth |
+ argument, EQU? is the equality predicate. |
Examples:
(substq 'tempest 'hurricane '(shakespeare wrote (the hurricane)))
@@ -8895,7 +9379,7 @@ Tree operations
'((old . spice) ((old . shoes) old . pair) (old . pair)))
=> ((old . spice) ((old . shoes) a . cons) (a . cons))
- - Function: copy-tree TREE
+ - 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.
@@ -8908,8 +9392,8 @@ Tree operations
=> #f

-File: slib.info, Node: Chapter Ordering, Next: Sorting, Prev: Tree Operations, Up: Procedures
-
+File: slib.info, Node: Chapter Ordering, Next: Sorting, Prev: Tree Operations, Up: Sorting and Searching
+ |
Chapter Ordering
----------------
@@ -8920,7 +9404,7 @@ 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
+ - 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<?'
@@ -8930,13 +9414,13 @@ like case.
(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
+ - 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
+ - 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.
@@ -8947,15 +9431,15 @@ like case.
(chap:next-string "Revised^{4}") => "Revised^{5}"

-File: slib.info, Node: Sorting, Next: Topological Sort, Prev: Chapter Ordering, Up: Procedures
-
+File: slib.info, Node: Sorting, Next: Topological Sort, Prev: Chapter Ordering, Up: Sorting and Searching
+ |
Sorting
-------
`(require 'sort)'
Many Scheme systems provide some kind of sorting functions. They do
-not, however, always provide the *same* sorting functions, and those
+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).
@@ -9008,7 +9492,7 @@ and Elk offers
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*
+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
@@ -9024,7 +9508,7 @@ 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
+ 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,
@@ -9034,9 +9518,9 @@ arguments which acts like `<'. For example,
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'.
+as saying when `x' must _not_ precede `y'.
- - Function: sorted? SEQUENCE LESS?
+ - 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)').
@@ -9045,16 +9529,16 @@ as saying when `x' must *not* precede `y'.
pair. It is an error if the sequence is neither a list nor a
vector.
- - Function: merge LIST1 LIST2 LESS?
+ - 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
+ _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.
+ _order_ of the arguments.
- - Procedure: merge! LIST1 LIST2 LESS?
+ - 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
@@ -9066,14 +9550,14 @@ as saying when `x' must *not* precede `y'.
done per iteration. (For example, we only have one `null?' test
per iteration.)
- - Function: sort SEQUENCE LESS?
+ - 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.
+ _elements_ with the old one; no elements are copied.
- - Procedure: sort! SEQUENCE LESS?
+ - 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
@@ -9086,7 +9570,7 @@ as saying when `x' must *not* precede `y'.
is the proper usage, not
(sort! slist <)
- Note that these functions do *not* accept a CL-style `:key' argument.
+ 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))))
@@ -9100,8 +9584,8 @@ in Common LISP, just write
in Scheme.

-File: slib.info, Node: Topological Sort, Next: String-Case, Prev: Sorting, Up: Procedures
-
+File: slib.info, Node: Topological Sort, Next: String Search, Prev: Sorting, Up: Sorting and Searching
+ |
Topological Sort
----------------
@@ -9110,8 +9594,8 @@ Topological Sort
The algorithm is inspired by Cormen, Leiserson and Rivest (1990)
`Introduction to Algorithms', chapter 23.
- - Function: tsort DAG PRED
- - Function: topological-sort DAG PRED
+ - Function: tsort dag pred
+ - Function: topological-sort dag pred
where
DAG
is a list of sublists. The car of each sublist is a vertex.
@@ -9150,67 +9634,25 @@ The algorithm is inspired by Cormen, Leiserson and Rivest (1990)
(socks undershorts pants shoes watch shirt belt tie jacket)

-File: slib.info, Node: String-Case, Next: String Ports, Prev: Topological Sort, Up: Procedures
-
-String-Case
------------
-
- `(require 'string-case)'
-
- - Procedure: string-upcase STR
- - Procedure: string-downcase STR
- - Procedure: string-capitalize STR
- The obvious string conversion routines. These are non-destructive.
-
- - Function: string-upcase! STR
- - Function: string-downcase! STR
- - Function: string-captialize! STR
- The destructive versions of the functions above.
-
- - Function: string-ci->symbol STR
- Converts string STR to a symbol having the same case as if the
- symbol had been `read'.
-
-
-File: slib.info, Node: String Ports, Next: String Search, Prev: String-Case, Up: Procedures
-
-String Ports
-------------
-
- `(require 'string-port)'
-
- - Procedure: call-with-output-string PROC
- PROC must be a procedure of one argument. This procedure calls
- PROC with one argument: a (newly created) output port. When the
- function returns, the string composed of the characters written
- into the port is returned.
-
- - Procedure: call-with-input-string STRING PROC
- PROC must be a procedure of one argument. This procedure calls
- PROC with one argument: an (newly created) input port from which
- STRING's contents may be read. When PROC returns, the port is
- closed and the value yielded by the procedure PROC is returned.
-
-
-File: slib.info, Node: String Search, Next: Line I/O, Prev: String Ports, Up: Procedures
-
+File: slib.info, Node: String Search, Next: Sequence Comparison, Prev: Topological Sort, Up: Sorting and Searching
+ |
String Search
-------------
`(require 'string-search)'
- - Procedure: string-index STRING CHAR
- - Procedure: string-index-ci STRING CHAR
+ - 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
+ - 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
+ - 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
@@ -9220,18 +9662,18 @@ String Search
(substring? "rat" "outrage") => #f
(substring? "" any-string) => 0
- - Procedure: find-string-from-port? STR IN-PORT MAX-NO-CHARS
+ - Procedure: find-string-from-port? str in-port 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
+ - 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
+ - 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
+ - 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.
@@ -9241,25 +9683,182 @@ String Search
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,
+ `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 ...
+ - Function: string-subst txt old1 new1 ...
Returns a copy of string TXT with all occurrences of string OLD1
in TXT replaced with NEW1, OLD2 replaced with NEW2 ....

-File: slib.info, Node: Line I/O, Next: Multi-Processing, Prev: String Search, Up: Procedures
-
+File: slib.info, Node: Sequence Comparison, Prev: String Search, Up: Sorting and Searching
+ |
+Sequence Comparison |
+------------------- |
+ |
+ `(require 'diff)' |
+ |
+This package implements the algorithm: |
+ |
+ S. Wu, E. Myers, U. Manber, and W. Miller, |
+ "An O(NP) Sequence Comparison Algorithm," |
+ Information Processing Letters 35, 6 (1990), 317-323. |
+ <http://www.cs.arizona.edu/people/gene/vita.html> |
+ |
+If the items being sequenced are text lines, then the computed |
+edit-list is equivalent to the output of the "diff" utility program. |
+If the items being sequenced are words, then it is like the lesser |
+known "spiff" program. |
+ |
+The values returned by `diff:edit-length' can be used to gauge the |
+degree of match between two sequences. |
+ |
+I believe that this algorithm is currently the fastest for these tasks, |
+but genome sequencing applications fuel extensive research in this area. |
+ |
+ - Function: diff:longest-common-subsequence array1 array2 =? |
+ - Function: diff:longest-common-subsequence array1 array2 |
+ ARRAY1 and ARRAY2 are one-dimensional arrays. The procedure =? is |
+ used to compare sequence tokens for equality. =? defaults to |
+ `eqv?'. `diff:longest-common-subsequence' returns a |
+ one-dimensional array of length `(quotient (- (+ len1 len2) |
+ (fp:edit-length ARRAY1 ARRAY2)) 2)' holding the longest sequence |
+ common to both ARRAYs. |
+ |
+ - Function: diff:edits array1 array2 =? |
+ - Function: diff:edits array1 array2 |
+ ARRAY1 and ARRAY2 are one-dimensional arrays. The procedure =? is |
+ used to compare sequence tokens for equality. =? defaults to |
+ `eqv?'. `diff:edits' returns a list of length `(fp:edit-length |
+ ARRAY1 ARRAY2)' composed of a shortest sequence of edits |
+ transformaing ARRAY1 to ARRAY2. |
+ |
+ Each edit is a list of an integer and a symbol: |
+ (J insert) |
+ Inserts `(array-ref ARRAY1 J)' into the sequence. |
+ |
+ (K delete) |
+ Deletes `(array-ref ARRAY2 K)' from the sequence. |
+ |
+ - Function: diff:edit-length array1 array2 =? |
+ - Function: diff:edit-length array1 array2 |
+ ARRAY1 and ARRAY2 are one-dimensional arrays. The procedure =? is |
+ used to compare sequence tokens for equality. =? defaults to |
+ `eqv?'. `diff:edit-length' returns the length of the shortest |
+ sequence of edits transformaing ARRAY1 to ARRAY2. |
+ |
+ (diff:longest-common-subsequence '#(f g h i e j c k l m) |
+ '#(f g e h i j k p q r l m)) |
+ => #(f g h i j k l m) |
+ |
+ (diff:edit-length '#(f g h i e j c k l m) |
+ '#(f g e h i j k p q r l m)) |
+ => 6 |
+ |
+ (pretty-print (diff:edits '#(f g h i e j c k l m) |
+ '#(f g e h i j k p q r l m))) |
+ -| |
+ ((3 insert) ; e |
+ (4 delete) ; c |
+ (6 delete) ; h |
+ (7 insert) ; p |
+ (8 insert) ; q |
+ (9 insert)) ; r |
+ |
+
+File: slib.info, Node: Procedures, Next: Standards Support, Prev: Sorting and Searching, Up: Other Packages
+ |
+Procedures |
+========== |
+ |
+ Anything that doesn't fall neatly into any of the other categories |
+winds up here. |
+ |
+* Menu: |
+ |
+* Type Coercion:: 'coerce |
+* String-Case:: 'string-case |
+* String Ports:: 'string-port |
+* Line I/O:: 'line-i/o |
+* Multi-Processing:: 'process |
+* Metric Units:: Portable manifest types for numeric values. |
+ |
+
+File: slib.info, Node: Type Coercion, Next: String-Case, Prev: Procedures, Up: Procedures
+ |
+Type Coercion |
+------------- |
+ |
+ `(require 'coerce)' |
+ |
+ - Function: type-of obj |
+ Returns a symbol name for the type of OBJ. |
+ |
+ - Function: coerce obj result-type |
+ Converts and returns OBJ of type `char', `number', `string', |
+ `symbol', `list', or `vector' to RESULT-TYPE (which must be one of |
+ these symbols). |
+ |
+
+File: slib.info, Node: String-Case, Next: String Ports, Prev: Type Coercion, Up: Procedures
+ |
+String-Case |
+----------- |
+ |
+ `(require 'string-case)' |
+ |
+ - Procedure: string-upcase str |
+ - Procedure: string-downcase str |
+ - Procedure: string-capitalize str |
+ The obvious string conversion routines. These are non-destructive. |
+ |
+ - Function: string-upcase! str |
+ - Function: string-downcase! str |
+ - Function: string-captialize! str |
+ The destructive versions of the functions above. |
+ |
+ - Function: string-ci->symbol str |
+ Converts string STR to a symbol having the same case as if the |
+ symbol had been `read'. |
+ |
+ - Function: symbol-append obj1 ... |
+ Converts OBJ1 ... to strings, appends them, and converts to a |
+ symbol which is returned. Strings and numbers are converted to |
+ read's symbol case; the case of symbol characters is not changed. |
+ #f is converted to the empty string (symbol). |
+ |
+
+File: slib.info, Node: String Ports, Next: Line I/O, Prev: String-Case, Up: Procedures
+ |
+String Ports |
+------------ |
+ |
+ `(require 'string-port)' |
+ |
+ - Procedure: call-with-output-string proc |
+ PROC must be a procedure of one argument. This procedure calls |
+ PROC with one argument: a (newly created) output port. When the |
+ function returns, the string composed of the characters written |
+ into the port is returned. |
+ |
+ - Procedure: call-with-input-string string proc |
+ PROC must be a procedure of one argument. This procedure calls |
+ PROC with one argument: an (newly created) input port from which |
+ STRING's contents may be read. When PROC returns, the port is |
+ closed and the value yielded by the procedure PROC is returned. |
+ |
+
+File: slib.info, Node: Line I/O, Next: Multi-Processing, Prev: String Ports, Up: Procedures
+ |
Line I/O
--------
`(require 'line-i/o)'
- Function: read-line
- - Function: read-line PORT
+ - 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
@@ -9267,8 +9866,8 @@ Line I/O
which case it defaults to the value returned by
`current-input-port'.
- - Function: read-line! STRING
- - Function: read-line! STRING 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
@@ -9278,20 +9877,20 @@ Line I/O
which case it defaults to the value returned by
`current-input-port'.
- - Function: write-line STRING
- - Function: write-line STRING 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 omited, in which
+ 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
+ - Function: display-file path
+ - Function: display-file path port
Displays the contents of the file named by PATH to PORT. The PORT
argument may be ommited, in which case it defaults to the value
returned by `current-output-port'.

-File: slib.info, Node: Multi-Processing, Prev: Line I/O, Up: Procedures
+File: slib.info, Node: Multi-Processing, Next: Metric Units, Prev: Line I/O, Up: Procedures
Multi-Processing
----------------
@@ -9303,7 +9902,7 @@ 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
+ - 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
@@ -9316,7 +9915,201 @@ implementation, consider it an example of writing schedulers in Scheme.
- 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::.).
+ `process:queue', `(slib:exit)' is called (*note System::).
+
+
+File: slib.info, Node: Metric Units, Prev: Multi-Processing, Up: Procedures
+
+Metric Units
+------------
+
+ `(require 'metric-units)'
+
+ <http://swissnet.ai.mit.edu/~jaffer/MIXF.html>
+
+ "Metric Interchange Format" is a character string encoding for
+numerical values and units which:
+
+ * is unambiguous in all locales;
+
+ * uses only [TOG] "Portable Character Set" characters matching "Basic
+ Latin" characters in Plane 0 of the Universal Character Set [UCS];
+
+ * is transparent to [UTF-7] and [UTF-8] UCS transformation formats;
+
+ * is human readable and writable;
+
+ * is machine readable and writable;
+
+ * incorporates SI prefixes and units;
+
+ * incorporates [ISO 6093] numbers; and
+
+ * incorporates [IEC 60027-2] binary prefixes.
+
+ In the expression for the value of a quantity, the unit symbol is
+placed after the numerical value. A dot (PERIOD, `.') is placed between
+the numerical value and the unit symbol.
+
+ Within a compound unit, each of the base and derived symbols can
+optionally have an attached SI prefix.
+
+ Unit symbols formed from other unit symbols by multiplication are
+indicated by means of a dot (PERIOD, `.') placed between them.
+
+ Unit symbols formed from other unit symbols by division are indicated
+by means of a SOLIDUS (`/') or negative exponents. The SOLIDUS must
+not be repeated in the same compound unit unless contained within a
+parenthesized subexpression.
+
+ The grouping formed by a prefix symbol attached to a unit symbol
+constitutes a new inseparable symbol (forming a multiple or submultiple
+of the unit concerned) which can be raised to a positive or negative
+power and which can be combined with other unit symbols to form compound
+unit symbols.
+
+ The grouping formed by surrounding compound unit symbols with
+parentheses (`(' and `)') constitutes a new inseparable symbol which
+can be raised to a positive or negative power and which can be combined
+with other unit symbols to form compound unit symbols.
+
+ Compound prefix symbols, that is, prefix symbols formed by the
+juxtaposition of two or more prefix symbols, are not permitted.
+
+ Prefix symbols are not used with the time-related unit symbols min
+(minute), h (hour), d (day). No prefix symbol may be used with dB
+(decibel). Only submultiple prefix symbols may be used with the unit
+symbols L (liter), Np (neper), o (degree), oC (degree Celsius), rad
+(radian), and sr (steradian). Submultiple prefix symbols may not be
+used with the unit symbols t (metric ton), r (revolution), or Bd (baud).
+
+ A unit exponent follows the unit, separated by a CIRCUMFLEX (`^').
+Exponents may be positive or negative. Fractional exponents must be
+parenthesized.
+
+SI Prefixes
+...........
+
+ Factor Name Symbol | Factor Name Symbol
+ ====== ==== ====== | ====== ==== ======
+ 1e24 yotta Y | 1e-1 deci d
+ 1e21 zetta Z | 1e-2 centi c
+ 1e18 exa E | 1e-3 milli m
+ 1e15 peta P | 1e-6 micro u
+ 1e12 tera T | 1e-9 nano n
+ 1e9 giga G | 1e-12 pico p
+ 1e6 mega M | 1e-15 femto f
+ 1e3 kilo k | 1e-18 atto a
+ 1e2 hecto h | 1e-21 zepto z
+ 1e1 deka da | 1e-24 yocto y
+
+Binary Prefixes
+...............
+
+ These binary prefixes are valid only with the units B (byte) and bit.
+However, decimal prefixes can also be used with bit; and decimal
+multiple (not submultiple) prefixes can also be used with B (byte).
+
+ Factor (power-of-2) Name Symbol
+ ====== ============ ==== ======
+ 1.152921504606846976e18 (2^60) exbi Ei
+ 1.125899906842624e15 (2^50) pebi Pi
+ 1.099511627776e12 (2^40) tebi Ti
+ 1.073741824e9 (2^30) gibi Gi
+ 1.048576e6 (2^20) mebi Mi
+ 1.024e3 (2^10) kibi Ki
+
+Unit Symbols
+............
+
+ Type of Quantity Name Symbol Equivalent
+ ================ ==== ====== ==========
+ time second s
+ time minute min = 60.s
+ time hour h = 60.min
+ time day d = 24.h
+ frequency hertz Hz s^-1
+ signaling rate baud Bd s^-1
+ length meter m
+ volume liter L dm^3
+ plane angle radian rad
+ solid angle steradian sr rad^2
+ plane angle revolution * r = 6.283185307179586.rad
+ plane angle degree * o = 2.777777777777778e-3.r
+ information capacity bit bit
+ information capacity byte, octet B = 8.bit
+ mass gram g
+ mass ton t Mg
+ mass unified atomic mass unit u = 1.66053873e-27.kg
+ amount of substance mole mol
+ catalytic activity katal kat mol/s
+ thermodynamic temperature kelvin K
+ centigrade temperature degree Celsius oC
+ luminous intensity candela cd
+ luminous flux lumen lm cd.sr
+ illuminance lux lx lm/m^2
+ force newton N m.kg.s^-2
+ pressure, stress pascal Pa N/m^2
+ energy, work, heat joule J N.m
+ energy electronvolt eV = 1.602176462e-19.J
+ power, radiant flux watt W J/s
+ logarithm of power ratio neper Np
+ logarithm of power ratio decibel * dB = 0.1151293.Np
+ electric current ampere A
+ electric charge coulomb C s.A
+ electric potential, EMF volt V W/A
+ capacitance farad F C/V
+ electric resistance ohm Ohm V/A
+ electric conductance siemens S A/V
+ magnetic flux weber Wb V.s
+ magnetic flux density tesla T Wb/m^2
+ inductance henry H Wb/A
+ radionuclide activity becquerel Bq s^-1
+ absorbed dose energy gray Gy m^2.s^-2
+ dose equivalent sievert Sv m^2.s^-2
+
+ * The formulas are:
+
+ * r/rad = 8 * atan(1)
+
+ * o/r = 1 / 360
+
+ * db/Np = ln(10) / 20
+
+ - Function: si:conversion-factor to-unit from-unit
+ If the strings FROM-UNIT and TO-UNIT express valid unit
+ expressions for quantities of the same unit-dimensions, then the
+ value returned by `si:conversion-factor' will be such that
+ multiplying a numerical value expressed in FROM-UNITs by the
+ returned conversion factor yields the numerical value expressed in
+ TO-UNITs.
+
+ Otherwise, `si:conversion-factor' returns:
+
+ -3
+ if neither FROM-UNIT nor TO-UNIT is a syntactically valid
+ unit.
+
+ -2
+ if FROM-UNIT is not a syntactically valid unit.
+
+ -1
+ if TO-UNIT is not a syntactically valid unit.
+
+ 0
+ if linear conversion (by a factor) is not possible.
+
+
+ (si:conversion-factor "km/s" "m/s" ) => 0.001
+ (si:conversion-factor "N" "m/s" ) => 0
+ (si:conversion-factor "moC" "oC" ) => 1000
+ (si:conversion-factor "mK" "oC" ) => 0
+ (si:conversion-factor "rad" "o" ) => 0.0174533
+ (si:conversion-factor "K" "o" ) => 0
+ (si:conversion-factor "K" "K" ) => 1
+ (si:conversion-factor "oK" "oK" ) => -3
+ (si:conversion-factor "" "s/s" ) => 1
+ (si:conversion-factor "km/h" "mph" ) => -2

File: slib.info, Node: Standards Support, Next: Session Support, Prev: Procedures, Up: Other Packages
@@ -9337,6 +10130,7 @@ Standards Support
* Dynamic-Wind:: 'dynamic-wind
* Eval:: 'eval
* Values:: 'values
+* SRFI:: 'http://srfi.schemers.org/srfi-0/srfi-0.html |

File: slib.info, Node: With-File, Next: Transcripts, Prev: Standards Support, Up: Standards Support
@@ -9346,8 +10140,8 @@ With-File
`(require 'with-file)'
- - Function: with-input-from-file FILE THUNK
- - Function: with-output-to-file FILE THUNK
+ - Function: with-input-from-file file thunk
+ - Function: with-output-to-file file thunk
Description found in R4RS.

@@ -9358,8 +10152,8 @@ Transcripts
`(require 'transcript)'
- - Function: transcript-on FILENAME
- - Function: transcript-off FILENAME
+ - Function: transcript-on filename
+ - Function: transcript-off filename
Redefines `read-char', `read', `write-char', `write', `display',
and `newline'.
@@ -9375,8 +10169,8 @@ Rev2 Procedures
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
+ - 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
@@ -9392,19 +10186,19 @@ Scheme->C, for instance, barfs on this module.
increasing indices. `substring-move-right!' stores characters in
time order of increasing indeces.
- - Procedure: substring-fill! STRING START END CHAR
+ - Procedure: substring-fill! string start end char
Fills the elements START-END of STRING with the character CHAR.
- - Function: string-null? STR
+ - Function: string-null? str
== `(= 0 (string-length STR))'
- - Procedure: append! . PAIRS
+ - Procedure: append! pair1 ... |
Destructively appends its arguments. Equivalent to `nconc'.
- - Function: 1+ N
+ - Function: 1+ n
Adds 1 to N.
- - Function: -1+ N
+ - Function: -1+ n
Subtracts 1 from N.
- Function: <?
@@ -9426,21 +10220,21 @@ Rev4 Optional Procedures
For the specification of these optional procedures, *Note Standard
procedures: (r4rs)Standard procedures.
- - Function: list-tail L P
+ - Function: list-tail l p
- - Function: string->list S
+ - Function: string->list s
- - Function: list->string L
+ - Function: list->string l
- Function: string-copy
- - Procedure: string-fill! S OBJ
+ - Procedure: string-fill! s obj
- - Function: list->vector L
+ - Function: list->vector l
- - Function: vector->list S
+ - Function: vector->list s
- - Procedure: vector-fill! S OBJ
+ - Procedure: vector-fill! s obj

File: slib.info, Node: Multi-argument / and -, Next: Multi-argument Apply, Prev: Rev4 Optional Procedures, Up: Standards Support
@@ -9454,15 +10248,15 @@ Multi-argument / and -
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
+ - Function: two-arg:/ n1 n2
The original two-argument version of `/'.
- - Function: / DIVIDENT . DIVISORS
+ - Function: / dividend divisor1 ... |
- - Function: two-arg:- N1 N2
+ - Function: two-arg:- n1 n2
The original two-argument version of `-'.
- - Function: - MINUEND . SUBTRAHENDS
+ - Function: - minuend subtrahend1 ... |

File: slib.info, Node: Multi-argument Apply, Next: Rationalize, Prev: Multi-argument / and -, Up: Standards Support
@@ -9475,11 +10269,11 @@ Multi-argument Apply
For the specification of this optional form, *Note Control features:
(r4rs)Control features.
- - Function: two-arg:apply PROC L
+ - 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
+ - Function: apply proc arg1 ... |

File: slib.info, Node: Rationalize, Next: Promises, Prev: Multi-argument Apply, Up: Standards Support
@@ -9489,15 +10283,33 @@ Rationalize
`(require 'rationalize)'
- The procedure rationalize is interesting because most programming
-languages do not provide anything analogous to it. For simplicity, we
-present an algorithm which computes the correct result for exact
-arguments (provided the implementation supports exact rational numbers
-of unlimited precision), and produces a reasonable answer for inexact
-arguments when inexact arithmetic is implemented using floating-point.
-We thank Alan Bawden for contributing this algorithm.
+ 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.
- - Function: rationalize X E
+ (find-ratio-between 2/7 3/5) => (1 2)
+ (find-ratio-between -3/5 -2/7) => (-1 2)

File: slib.info, Node: Promises, Next: Dynamic-Wind, Prev: Rationalize, Up: Standards Support
@@ -9507,7 +10319,7 @@ Promises
`(require 'promise)'
- - Function: make-promise PROC
+ - Function: make-promise proc
Change occurrences of `(delay EXPRESSION)' to `(make-promise (lambda
() EXPRESSION))' and `(define force promise:force)' to implement
@@ -9526,7 +10338,7 @@ Dynamic-Wind
designed to take into account the fact that continuations produced by
`call-with-current-continuation' may be reentered.
- - Procedure: dynamic-wind THUNK1 THUNK2 THUNK3
+ - Procedure: dynamic-wind thunk1 thunk2 thunk3
The arguments THUNK1, THUNK2, and THUNK3 must all be procedures of
no arguments (thunks).
@@ -9552,7 +10364,7 @@ Eval
`(require 'eval)'
- - Function: eval EXPRESSION ENVIRONMENT-SPECIFIER
+ - 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
@@ -9571,8 +10383,8 @@ Eval
(f + 10))
=> 20
- - Function: scheme-report-environment VERSION
- - Function: null-environment VERSION
+ - 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.
@@ -9628,18 +10440,18 @@ Here are some more `eval' examples:
=> buick

-File: slib.info, Node: Values, Prev: Eval, Up: Standards Support
-
+File: slib.info, Node: Values, Next: SRFI, Prev: Eval, Up: Standards Support
+ |
Values
------
`(require 'values)'
- - Function: values OBJ ...
+ - Function: values obj ...
`values' takes any number of arguments, and passes (returns) them
to its continuation.
- - Function: call-with-values THUNK PROC
+ - 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
@@ -9652,8 +10464,180 @@ Values
unspecified.

+File: slib.info, Node: SRFI, Prev: Values, Up: Standards Support
+ |
+SRFI |
+---- |
+ |
+ `(require 'srfi)' |
+ |
+Implements "Scheme Request For Implementation" (SRFI) as described at |
+<http://srfi.schemers.org/> |
+ |
+The Copyright terms of each SRFI states: |
+ "However, this document itself may not be modified in any way, ..." |
+ |
+Therefore, the specification of SRFI constructs must not be quoted |
+without including the complete SRFI document containing discussion and |
+a sample implementation program. |
+ |
+ - Macro: cond-expand <clause1> <clause2> ... |
+ _Syntax:_ Each <clause> should be of the form |
+ |
+ (<feature> <expression1> ...) |
+ |
+ where <feature> is a boolean expression composed of symbols and |
+ `and', `or', and `not' of boolean expressions. The last <clause> |
+ may be an "else clause," which has the form |
+ |
+ (else <expression1> <expression2> ...). |
+ |
+ The first clause whose feature expression is satisfied is expanded. |
+ If no feature expression is satisfied and there is no else clause, |
+ an error is signaled. |
+ |
+ SLIB `cond-expand' is an extension of SRFI-0, |
+ <http://srfi.schemers.org/srfi-0/srfi-0.html>. |
+ |
+* Menu: |
+ |
+* SRFI-1:: list-processing |
+ |
+
+File: slib.info, Node: SRFI-1, Prev: SRFI, Up: SRFI
+ |
+SRFI-1 |
+...... |
+ |
+ `(require 'srfi-1)' |
+ |
+Implements the "SRFI-1" "list-processing library" as described at |
+<http://srfi.schemers.org/srfi-1/srfi-1.html> |
+ |
+Constructors |
+------------ |
+ |
+ - Function: xcons d a |
+ `(define (xcons d a) (cons a d))'. |
+ |
+ - Function: list-tabulate len proc |
+ Returns a list of length LEN. Element I is `(PROC I)' for 0 <= I |
+ < LEN. |
+ |
+ - Function: cons* obj1 obj2 |
+ |
+ - Function: iota count start step |
+ - Function: iota count start |
+ - Function: iota count |
+ Returns a list of COUNT numbers: (START, START+STEP, ..., |
+ START+(COUNT-1)*STEP). |
+ |
+ - Function: circular-list obj1 obj2 ... |
+ Returns a circular list of OBJ1, OBJ2, .... |
+ |
+Predicates |
+---------- |
+ |
+ - Function: proper-list? obj |
+ |
+ - Function: circular-list? x |
+ |
+ - Function: dotted-list? obj |
+ |
+ - Function: null-list? obj |
+ |
+ - Function: not-pair? obj |
+ |
+ - Function: list= =pred list ... |
+ |
+Selectors |
+--------- |
+ |
+ - Function: first pair |
+ - Function: fifth obj |
+ - Function: sixth obj |
+ - Function: seventh obj |
+ - Function: eighth obj |
+ - Function: ninth obj |
+ - Function: tenth obj |
+ |
+ - Function: car+cdr pair |
+ |
+ - Function: take lst k |
+ - Function: drop lst k |
+ |
+ - Function: take-right lst k |
+ |
+ - Function: split-at lst k |
+ |
+ - Function: last lst |
+ (car (last-pair lst)) |
+ |
+Miscellaneous |
+------------- |
+ |
+ - Function: length+ obj |
+ |
+ - Function: concatenate lists |
+ - Function: concatenate! lists |
+ |
+ - Function: reverse! lst |
+ |
+ - Function: append-reverse rev-head tail |
+ - Function: append-reverse! rev-head tail |
+ |
+ - Function: zip list1 list2 ... |
+ |
+ - Function: unzip1 lst |
+ - Function: unzip2 lst |
+ - Function: unzip3 lst |
+ - Function: unzip4 lst |
+ - Function: unzip5 lst |
+ |
+ - Function: count pred list1 list2 ... |
+ |
+Fold and Unfold |
+--------------- |
+ |
+Filtering and Partitioning |
+-------------------------- |
+ |
+Searching |
+--------- |
+ |
+ - Function: find pred list |
+ |
+ - Function: find-tail pred list |
+ |
+ - Function: member obj list pred |
+ - Function: member obj list |
+ `member' returns the first sublist of LIST whose car is OBJ, where |
+ the sublists of LIST are the non-empty lists returned by |
+ (list-tail LIST K) for K less than the length of LIST. If OBJ |
+ does not occur in LIST, then #f (not the empty list) is returned. |
+ The procedure PRED is used for testing equality. If PRED is not |
+ provided, `equal?' is used. |
+ |
+Deleting |
+-------- |
+ |
+Association lists |
+----------------- |
+ |
+ - Function: assoc obj alist pred |
+ - Function: assoc obj alist |
+ ALIST (for "association list") must be a list of pairs. These |
+ procedures find the first pair in ALIST whose car field is OBJ, and |
+ returns that pair. If no pair in ALIST has OBJ as its car, then #f |
+ (not the empty list) is returned. The procedure PRED is used for |
+ testing equality. If PRED is not provided, `equal?' is used. |
+ |
+Set operations |
+-------------- |
+ |
+
File: slib.info, Node: Session Support, Next: Extra-SLIB Packages, Prev: Standards Support, Up: Other Packages
-
+ |
Session Support
===============
@@ -9676,7 +10660,7 @@ Repl
Here is a read-eval-print-loop which, given an eval, evaluates forms.
- - Procedure: repl:top-level REPL:EVAL
+ - 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',
@@ -9717,11 +10701,11 @@ 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.
+ strings and bit-vectors are _not_ limited.
- - Procedure: qp ARG1 ...
- - Procedure: qpn ARG1 ...
- - Procedure: qpr ARG1 ...
+ - 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.
@@ -9749,13 +10733,21 @@ printer for `qp'. This example shows how to do this:
(provide 'qp)
(require 'debug)
- - Procedure: trace-all FILE
- Traces (*note Trace::.) all procedures `define'd at top-level in
- file `file'.
+ - Procedure: trace-all file ...
+ Traces (*note Trace::) all procedures `define'd at top-level in
+ `file' ....
- - Procedure: break-all FILE
- Breakpoints (*note Breakpoints::.) all procedures `define'd at
- top-level in file `file'.
+ - Procedure: track-all file ...
+ Tracks (*note Trace::) all procedures `define'd at top-level in
+ `file' ....
+
+ - Procedure: stack-all file ...
+ Stacks (*note Trace::) all procedures `define'd at top-level in
+ `file' ....
+
+ - Procedure: break-all file ...
+ Breakpoints (*note Breakpoints::) all procedures `define'd at
+ top-level in `file' ....

File: slib.info, Node: Breakpoints, Next: Trace, Prev: Debug, Up: Session Support
@@ -9772,7 +10764,7 @@ Breakpoints
establish a top-level continuation. Typing `(init-debug)' at top
level sets up a continuation for `break'.
- - Function: breakpoint ARG1 ...
+ - Function: breakpoint arg1 ...
Returns from the top level continuation and pushes the
continuation from which it was called on a continuation stack.
@@ -9780,11 +10772,11 @@ Breakpoints
Pops the topmost continuation off of the continuation stack and
returns an unspecified value to it.
- - Function: continue ARG1 ...
+ - Function: continue arg1 ...
Pops the topmost continuation off of the continuation stack and
returns ARG1 ... to it.
- - Macro: break PROC1 ...
+ - Macro: break proc1 ...
Redefines the top-level named procedures given as arguments so that
`breakpoint' is called before calling PROC1 ....
@@ -9793,22 +10785,18 @@ Breakpoints
identifiers are broken (even if those identifiers have been
redefined) and returns a list of the broken identifiers.
- - Macro: unbreak PROC1 ...
+ - Macro: unbreak proc1 ...
Turns breakpoints off for its arguments.
- Macro: unbreak
With no arguments, unbreaks all currently broken identifiers and
returns a list of these formerly broken identifiers.
- The following routines are the procedures which actually do the
-tracing when this module is supplied by SLIB, rather than natively. If
-defmacros are not natively supported by your implementation, these might
-be more convenient to use.
+ 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
- - Function: debug:breakf PROC
- - Function: debug:breakf PROC NAME
+ - Function: breakf proc
+ - Function: breakf proc name
To break, type
(set! SYMBOL (breakf SYMBOL))
@@ -9821,8 +10809,7 @@ be more convenient to use.
or
(define SYMBOL (breakf FUNCTION 'SYMBOL))
- - Function: unbreakf PROC
- - Function: debug:unbreakf PROC
+ - Function: unbreakf proc
To unbreak, type
(set! SYMBOL (unbreakf SYMBOL))
@@ -9834,7 +10821,31 @@ Tracing
`(require 'trace)'
- - Macro: trace PROC1 ...
+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
@@ -9842,22 +10853,48 @@ Tracing
identifiers are traced (even if those identifiers have been
redefined) and returns a list of the traced identifiers.
- - Macro: untrace PROC1 ...
- Turns tracing off for its arguments.
+ - Macro: 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.
- The following routines are the procedures which actually do the
-tracing when this module is supplied by SLIB, rather than natively. If
-defmacros are not natively supported by your implementation, these might
-be more convenient to use.
+ - 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.
- - Function: tracef PROC
- - Function: tracef PROC NAME
- - Function: debug:tracef PROC
- - Function: debug:tracef PROC NAME
+ 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))
@@ -9870,9 +10907,8 @@ be more convenient to use.
or
(define SYMBOL (tracef FUNCTION 'SYMBOL))
- - Function: untracef PROC
- - Function: debug:untracef PROC
- To untrace, type
+ - Function: untracef proc
+ Removes tracing, tracking, or stacking for PROC. To untrace, type
(set! SYMBOL (untracef SYMBOL))

@@ -9883,14 +10919,14 @@ System Interface
If `(provided? 'getenv)':
- - Function: getenv NAME
+ - 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
+ - Function: system command-string
Executes the COMMAND-STRING on the computer and returns the
integer status code.
@@ -9900,8 +10936,8 @@ mail, and Netscape.
`(require 'net-clients)'
- - Function: call-with-tmpnam PROC
- - Function: call-with-tmpnam PROC K
+ - 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)
@@ -9921,25 +10957,25 @@ mail, and Netscape.
If `current-directory' cannot be supported by the platform, the
value of `current-directory' is #f.
- - Function: make-directory NAME
+ - 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
+ - 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
+ - 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
+ - Function: glob-pattern? str
Returns #t if the string STR contains characters used for
specifying glob patterns, namely `*', `?', or `['.
- - Function: parse-ftp-address URL
- Returns a list of the decoded FTP URL; or #f if indecipherable.
+ - 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:
@@ -9952,9 +10988,9 @@ mail, and Netscape.
3. remote-directory
- - Function: ftp-upload PATHS USER PASSWORD REMOTE-SITE REMOTE-DIR
+ - 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::.)
+ 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
@@ -9965,19 +11001,19 @@ mail, and Netscape.
is ignored; FTP takes the username and password from the `.netrc'
or equivalent file.
- - Function: path->url PATH
- Returns a URL-string for PATH on the local host.
+ - Function: path->uri path
+ Returns a URI-string for PATH on the local host.
- - Function: browse-url-netscape URL
+ - 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. |
+ `netscape' with the argument URL. If the browser starts as a
+ background job, `browse-url-netscape' returns #t immediately; if
+ the browser starts as a foreground job, then `browse-url-netscape'
+ returns #t when the browser exits; otherwise it returns #f.

File: slib.info, Node: Extra-SLIB Packages, Prev: Session Support, Up: Other Packages
@@ -10005,11 +11041,17 @@ distribution:
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 |
- ftp.gnu.org:pub/gnu/jacal/slib-psd1-3.tar.gz
- ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz
- ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz
+SLIB-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
@@ -10018,13 +11060,21 @@ SLIB-PSD is a portable debugger for Scheme (requires emacs editor).
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
+ 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'
+ 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/'
+SCHELOG
+ is an embedding of Prolog in Scheme.
+ http://www.cs.rice.edu/CS/PLT/packages/schelog/
+
+
+JFILTER
+ is a Scheme program which converts text among the JIS, EUC, and
+ Shift-JIS Japanese character sets.
+ http://www.sci.toyama-u.ac.jp/~iwao/Scheme/Jfilter/index.html

File: slib.info, Node: About SLIB, Next: Index, Prev: Other Packages, Up: Top
@@ -10032,30 +11082,55 @@ File: slib.info, Node: About SLIB, Next: Index, Prev: Other Packages, Up: To
About SLIB
**********
-More people than I can name have contributed to SLIB. Thanks to all of |
-you! |
- |
- SLIB 2c7, released December 1999. |
- Aubrey Jaffer <jaffer @ ai.mit.edu> |
- Hyperactive Software - The Maniac Inside! |
- `http://swissnet.ai.mit.edu/~jaffer/SLIB.html' |
- |
+More people than I can name have contributed to SLIB. Thanks to all of
+you!
+
+ SLIB 2d2, released July 2001. |
+ Aubrey Jaffer <agj @ alum.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 Standards:: How to write modules for SLIB.
+* Coding Guidelines:: How to write modules for SLIB.
* Copyrights:: Intellectual propery issues.
- |
+

File: slib.info, Node: Installation, Next: Porting, Prev: About SLIB, Up: About SLIB
Installation
============
- Check the manifest in `README' to find a configuration file for your
-Scheme implementation. Initialization files for most IEEE P1178
-compliant Scheme Implementations are included with this distribution.
+ There are four parts to installation: |
+ |
+ * Unpack the SLIB distribution. |
+ |
+ * Configure the Scheme implementation(s) to locate the SLIB |
+ directory. |
+ |
+ * Arrange for Scheme implementation to load its SLIB initialization |
+ file. |
+ |
+ * Build the SLIB catalog for the Scheme implementation. |
+ |
+Unpacking the SLIB Distribution |
+------------------------------- |
+ |
+ If the SLIB distribution is a Linux RPM, it will create the SLIB |
+directory `/usr/share/slib'. |
+ |
+ If the SLIB distribution is a ZIP file, unzip the distribution to |
+create the SLIB directory. Locate this `slib' directory either in your |
+home directory (if only you will use this SLIB installation); or put it |
+in a location where libraries reside on your system. On unix systems |
+this might be `/usr/share/slib', `/usr/local/lib/slib', or |
+`/usr/lib/slib'. If you know where SLIB should go on other platforms, |
+please inform agj @ alum.mit.edu. |
+ |
+Configure Scheme Implementation to Locate SLIB |
+---------------------------------------------- |
If the Scheme implementation supports `getenv', then the value of the
shell environment variable SCHEME_LIBRARY_PATH will be used for
@@ -10064,33 +11139,104 @@ 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.)
+ The `(library-vicinity)' can also be specified from the SLIB |
+initialization file or by implementation-specific means. |
+ |
+Loading SLIB Initialization File |
+-------------------------------- |
+ |
+ 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. |
+ |
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.
+ Once this is done, modify the startup file for your Scheme |
+implementation to `load' this initialization file. |
+ |
+Build New SLIB Catalog for Implementation |
+----------------------------------------- |
+ |
+ When SLIB is first used from an implementation, a file named |
+`slibcat' is written to the `implementation-vicinity' for that |
+implementation. Because users may lack permission to write in |
+`implementation-vicinity', it is good practice to build the new catalog |
+when installing SLIB. |
+ |
+ To build (or rebuild) the catalog, start the Scheme implementation |
+(with SLIB), then: |
+ |
+ (require 'new-catalog) |
+ |
+Implementation-specific Instructions |
+------------------------------------ |
Multiple implementations of Scheme can all use the same SLIB
directory. Simply configure each implementation's initialization file
as outlined above.
- The SCM implementation does not require any initialization file as
-SLIB support is already built in to SCM. See the documentation with
-SCM for installation instructions.
+ - 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.)
- SLIB includes methods to create heap images for the VSCM and Scheme48
-implementations. The instructions for creating a VSCM image are in
-comments in `vscm.init'. To make a Scheme48 image for an installation
-under `<prefix>', `cd' to the SLIB directory and type `make
-prefix=<prefix> slib48'. 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: 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
+ The `init.ss' file in the _slibinit_ collection is an SLIB |
+ initialization file. |
+ |
+ To use SLIB in MzScheme, set the SCHEME_LIBRARY_PATH environment |
+ variable to the installed SLIB location; then invoke MzScheme thus: |
+ |
+ `mzscheme -L init.ss slibinit' |
+ |
+ - Implementation: MIT Scheme |
+ `scheme -load ${SCHEME_LIBRARY_PATH}mitscheme.init' |
+
+ - Implementation: Guile |
+ `guile -l ${SCHEME_LIBRARY_PATH}guile.init' |

-File: slib.info, Node: Porting, Next: Coding Standards, Prev: Installation, Up: About SLIB
+File: slib.info, Node: Porting, Next: Coding Guidelines, Prev: Installation, Up: About SLIB
Porting
=======
@@ -10114,7 +11260,7 @@ library; this will allow the use of `provide', `provided?', and
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'
+ Please mail new working configuration files to `agj @ alum.mit.edu' |
so that they can be included in the SLIB distribution.
---------- Footnotes ----------
@@ -10124,16 +11270,16 @@ Language Scheme' implementation, then you will need to finish writing
`sc4sc3.scm' and `load' it from your initialization file.

-File: slib.info, Node: Coding Standards, Next: Copyrights, Prev: Porting, Up: About SLIB
+File: slib.info, Node: Coding Guidelines, Next: Copyrights, Prev: Porting, Up: About SLIB
-Coding Standards
-================
+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::.).
+'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
@@ -10149,7 +11295,7 @@ packages.
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
+which tests your code. Please run this test _before_ you send me the
code!
Modifications
@@ -10168,13 +11314,13 @@ files).
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
+ Please _do not_ reformat the source code with your favorite
beautifier, make 10 fixes, and send me the resulting source code. I do
not have the time to fish through 10000 diffs to find your 10 real
fixes.

-File: slib.info, Node: Copyrights, Prev: Coding Standards, Up: About SLIB
+File: slib.info, Node: Copyrights, Prev: Coding Guidelines, Up: About SLIB
Copyrights
==========
@@ -10193,8 +11339,8 @@ 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.
+disclaimer and send it to the SLIB maintainer. Contact agj @ |
+alum.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.
@@ -10215,7 +11361,7 @@ 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
+maintainer. Contact agj @ alum.mit.edu for the address to mail the |
disclaimer to. An example disclaimer follows.
Explicit copying terms
@@ -10233,7 +11379,7 @@ into the Public Domain (by sending me a disclaimer) you need to:
* 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
+ disclaim to the SLIB maintainer. Contact agj @ alum.mit.edu for |
the address to mail the disclaimer to.
Example: Company Copyright Disclaimer
@@ -10290,13 +11436,9 @@ Procedure and Macro Index
* 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.
+* append-reverse: SRFI-1. |
+* append-reverse!: SRFI-1. |
+* apply: Multi-argument Apply. |
* array-copy!: Array Mapping.
* array-dimensions: Arrays.
* array-for-each: Array Mapping.
@@ -10308,20 +11450,22 @@ Procedure and Macro Index
* array-ref: Arrays.
* array-set!: Arrays.
* array-shape: Arrays.
+* array=?: Arrays. |
* array?: Arrays.
* asctime: Posix Time.
* ash: Bit-Twiddling.
-* atom?: Non-List functions. |
+* assoc: SRFI-1. |
+* atom?: Non-List functions.
* batch:call-with-output-script: Batch.
-* batch:command: 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. |
+* batch:try-chopped-command: Batch.
+* batch:try-command: Batch.
* bit-extract: Bit-Twiddling.
* bit-field: Bit-Twiddling.
* bitwise-if: Bit-Twiddling.
@@ -10344,30 +11488,38 @@ Procedure and Macro Index
* call-with-tmpnam: System Interface.
* call-with-values: Values.
* capture-syntactic-environment: Syntactic Closures.
+* car+cdr: SRFI-1. |
* cart-prod-tables: Relational Database Operations.
-* catalog->html: HTML HTTP and CGI.
-* catalog->page: HTML HTTP and CGI.
-* cgi:read-query-string: HTML HTTP and CGI.
-* cgi:serve-command: HTML HTTP and CGI.
+* 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.
+* circular-list: SRFI-1. |
+* circular-list?: SRFI-1. |
* close-base: Base Table.
* close-database: Relational Database Operations.
* close-table: Table Operations.
-* coerce: Non-List functions.
+* coerce: Type Coercion.
* collection?: Collections.
* combined-rulesets: Commutative Rings.
-* command->html: HTML HTTP and CGI.
+* command->p-specs: HTML.
+* command:make-editable-table: HTML Tables.
+* command:modify-table: HTML Tables.
+* concatenate: SRFI-1. |
+* concatenate!: SRFI-1. |
+* cond-expand: SRFI. |
+* cons*: SRFI-1. |
* continue: Breakpoints.
* copy-bit: Bit-Twiddling.
* copy-bit-field: Bit-Twiddling.
* copy-list: List construction.
* copy-random-state: Random Numbers.
* copy-tree: Tree Operations.
+* count: SRFI-1. |
* create-database <1>: Database Utilities.
* create-database: Creating and Opening Relational Databases.
* create-report: Database Reports.
@@ -10381,15 +11533,13 @@ Procedure and Macro Index
* current-input-port: Ruleset Definition and Use.
* current-output-port: Byte.
* current-time: Time and Date.
-* debug:breakf: Breakpoints.
-* debug:tracef: Trace.
-* debug:unbreakf: Breakpoints.
-* debug:untracef: Trace.
+* 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-predicate: Yasos interface. |
* define-syntax: Macro by Example.
* define-tables: Database Utilities.
* defmacro: Defmacro.
@@ -10406,15 +11556,22 @@ Procedure and Macro Index
* delete-if-not: Destructive list operations.
* delete-table: Relational Database Operations.
* dequeue!: Queues.
+* determinant: Determinant.
+* diff:edit-length: Sequence Comparison. |
+* diff:edits: Sequence Comparison. |
+* diff:longest-common-subsequence: Sequence Comparison. |
* difftime: Time and Date.
* display-file: Line I/O.
* do-elts: Collections.
* do-keys: Collections.
* domain-checker: Database Utilities.
+* dotted-list?: SRFI-1. |
+* drop: SRFI-1. |
* dynamic-ref: Dynamic Data Type.
* dynamic-set!: Dynamic Data Type.
* dynamic-wind: Dynamic-Wind.
* dynamic?: Dynamic Data Type.
+* eighth: SRFI-1. |
* empty?: Collections.
* encode-universal-time: Common-Lisp Time.
* enquque!: Queues.
@@ -10426,20 +11583,31 @@ Procedure and Macro Index
* factor: Prime Numbers.
* fft: Fast Fourier Transform.
* fft-1: Fast Fourier Transform.
+* fifth: SRFI-1. |
* file-exists?: Input/Output.
* filename:match-ci??: Filenames.
* filename:match??: Filenames.
* filename:substitute-ci??: Filenames.
* filename:substitute??: Filenames.
* fill-empty-parameters: Parameter lists.
+* find: SRFI-1. |
* find-if: Lists as sets.
+* find-ratio: Rationalize.
+* find-ratio-between: Rationalize.
* find-string-from-port?: String Search.
+* find-tail: SRFI-1. |
+* first: SRFI-1. |
* 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.
@@ -10459,6 +11627,7 @@ Procedure and Macro Index
* glob-pattern?: System Interface.
* gmktime: Posix Time.
* gmtime: Posix Time.
+* golden-section-search: Minimizing.
* gtime: Posix Time.
* has-duplicates?: Lists as sets.
* hash: Hashing.
@@ -10473,18 +11642,37 @@ Procedure and Macro Index
* heap-insert!: Priority Queues.
* heap-length: Priority Queues.
* home-vicinity: Vicinity.
-* html:comment: HTML HTTP and CGI.
-* html:end-form: HTML HTTP and CGI.
-* html:end-page: HTML HTTP and CGI.
-* html:end-table: HTML HTTP and CGI.
-* html:heading: HTML HTTP and CGI.
-* html:href-heading: HTML HTTP and CGI.
-* html:pre: HTML HTTP and CGI.
-* html:start-form: HTML HTTP and CGI.
-* html:start-page: HTML HTTP and CGI.
-* html:start-table: HTML HTTP and CGI.
-* http:read-request-line: HTML HTTP and CGI.
-* http:serve-query: HTML HTTP and CGI.
+* 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.
@@ -10496,19 +11684,26 @@ Procedure and Macro Index
* integer-sqrt: Root Finding.
* interaction-environment: Eval.
* intersection: Lists as sets.
+* iota: SRFI-1. |
* jacobi-symbol: Prime Numbers.
* kill-process!: Multi-Processing.
* kill-table: Base Table.
* laguerre:find-polynomial-root: Root Finding.
* laguerre:find-root: Root Finding.
+* last <1>: SRFI-1. |
* last: Lists as sequences.
* last-pair: Legacy.
+* length+: SRFI-1. |
* 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-tabulate: SRFI-1. |
* list-tail: Rev4 Optional Procedures.
+* list=: SRFI-1. |
* load-option: Weight-Balanced Trees.
* localtime: Posix Time.
* logand: Bit-Twiddling.
@@ -10534,10 +11729,8 @@ Procedure and Macro Index
* macroexpand-1: Defmacro.
* macwork:eval: Macros That Work.
* macwork:expand: Macros That Work.
-* macwork:load: Macros That Work.
-* make-: Structures.
+* macwork:load: Macros That Work. |
* make-array: Arrays.
-* make-atval: HTML HTTP and CGI.
* make-base: Base Table.
* make-bytes: Byte.
* make-command-server: Database Utilities.
@@ -10556,27 +11749,28 @@ Procedure and Macro Index
* make-method!: Object.
* make-object: Object.
* make-parameter-list: Parameter lists.
-* make-plain: HTML HTTP and CGI.
* 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-row-converter: HTML HTTP and CGI.
* 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: SRFI-1. |
* member-if: Lists as sets.
* merge: Sorting.
* merge!: Sorting.
@@ -10595,12 +11789,15 @@ Procedure and Macro Index
* nconc: Destructive list operations.
* newton:find-root: Root Finding.
* newtown:find-integer-root: Root Finding.
+* ninth: SRFI-1. |
+* not-pair?: SRFI-1. |
* notany: Lists as sets.
* notevery: Lists as sets.
* nreverse: Destructive list operations.
* nthcdr: Lists as sequences.
* null-directory?: System Interface.
* null-environment: Eval.
+* null-list?: SRFI-1. |
* object: Yasos interface.
* object->limited-string: Object-To-String.
* object->string: Object-To-String.
@@ -10623,8 +11820,12 @@ Procedure and Macro Index
* parameter-list-expand: Parameter lists.
* parameter-list-ref: Parameter lists.
* parse-ftp-address: System Interface.
-* path->url: 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.
@@ -10647,14 +11848,17 @@ Procedure and Macro Index
* 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.
+* proper-list?: SRFI-1. |
* provide <1>: Require.
* provide: Feature.
* provided? <1>: Require.
@@ -10692,6 +11896,7 @@ Procedure and Macro Index
* 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.
@@ -10702,6 +11907,7 @@ Procedure and Macro Index
* require:feature->path <1>: Require.
* require:feature->path: Requesting Features.
* restrict-table: Relational Database Operations.
+* reverse!: SRFI-1. |
* row:delete: Table Operations.
* row:delete*: Table Operations.
* row:insert: Table Operations.
@@ -10719,13 +11925,14 @@ Procedure and Macro Index
* secant:find-bracketed-root: Root Finding.
* secant:find-root: Root Finding.
* seed->random-state: Random Numbers.
-* serve-urlencoded-command: HTML HTTP and CGI.
-* set: Setters.
-* set-: Structures.
+* set: Setters. |
* set-difference: Lists as sets.
* Setter: Collections.
* setter: Setters.
+* seventh: SRFI-1. |
+* si:conversion-factor: Metric Units.
* singleton-wt-tree: Construction of Weight-Balanced Trees.
+* sixth: SRFI-1. |
* size <1>: Collections.
* size: Yasos interface.
* slib:error: System.
@@ -10744,8 +11951,11 @@ Procedure and Macro Index
* sort!: Sorting.
* sorted?: Sorting.
* soundex: Hashing.
+* split-at: SRFI-1. |
* 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.
@@ -10774,8 +11984,10 @@ Procedure and Macro Index
* 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.
@@ -10784,11 +11996,12 @@ Procedure and Macro Index
* synclo:load: Syntactic Closures.
* syntax-rules: Macro by Example.
* system: System Interface.
-* table->html: HTML HTTP and CGI.
-* table->page: HTML HTTP and CGI.
+* table->linked-html: HTML Tables.
+* table->linked-page: HTML Tables.
* table-exists?: Relational Database Operations.
-* table-name->filename: HTML HTTP and CGI.
-* TAG: Structures.
+* table-name->filename: HTML Tables.
+* take: SRFI-1. |
+* take-right: SRFI-1. |
* tek40:draw: Tektronix Graphics Support.
* tek40:graphics: Tektronix Graphics Support.
* tek40:init: Tektronix Graphics Support.
@@ -10805,6 +12018,7 @@ Procedure and Macro Index
* tek41:move: Tektronix Graphics Support.
* tek41:point: Tektronix Graphics Support.
* tek41:reset: Tektronix Graphics Support.
+* tenth: SRFI-1. |
* time-zone: Time Zone.
* tmpnam: Input/Output.
* tok:char-group: Token definition.
@@ -10812,6 +12026,8 @@ Procedure and Macro Index
* trace: Trace.
* trace-all: Debug.
* tracef: Trace.
+* track: Trace.
+* track-all: Debug.
* transcript-off: Transcripts.
* transcript-on: Transcripts.
* transformer: Syntactic Closures.
@@ -10820,19 +12036,28 @@ Procedure and Macro Index
* two-arg:-: Multi-argument / and -.
* two-arg:/: Multi-argument / and -.
* two-arg:apply: Multi-argument Apply.
-* type-of: Non-List functions.
+* 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.
+* unzip1: SRFI-1. |
+* unzip2: SRFI-1. |
+* unzip3: SRFI-1. |
+* unzip4: SRFI-1. |
+* unzip5: SRFI-1. |
+* uri->tree: URI.
+* uric:decode: URI.
+* uric:encode: URI.
* user-email-address: System Interface.
* user-vicinity: Vicinity.
-* values: Values.
-* variant-case: Structures.
+* values: Values. |
* vector->list: Rev4 Optional Procedures.
* vector-fill!: Rev4 Optional Procedures.
* with-input-from-file: With-File.
@@ -10868,6 +12093,8 @@ Procedure and Macro Index
* 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.
+* xcons: SRFI-1. |
+* zip: SRFI-1. |
Variable Index
**************
@@ -10878,7 +12105,7 @@ Variable Index
* *catalog*: Require.
* *features*: Require.
-* *html:output-port*: HTML HTTP and CGI.
+* *http:byline*: HTTP and CGI.
* *modules*: Require.
* *optarg*: Getopt.
* *optind*: Getopt.
@@ -10898,6 +12125,7 @@ Variable Index
* 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.
@@ -10930,8 +12158,9 @@ Concept and Feature Index
* ange-ftp: System Interface.
* array: Arrays.
* array-for-each: Array Mapping.
-* attribute-value: HTML HTTP and CGI.
+* 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.
@@ -10945,8 +12174,10 @@ Concept and Feature Index
* careful: Commutative Rings.
* catalog: Requesting Features.
* Catalog File: Library Catalogs.
+* cgi: HTTP and CGI. |
* chapter-order: Chapter Ordering.
* charplot: Plotting.
+* coerce: Type Coercion.
* collect: Collections.
* command line: Command Line.
* commentfix: Precedence Parsing Overview.
@@ -10961,9 +12192,12 @@ Concept and Feature Index
* defmacroexpand <1>: Pretty-Print.
* defmacroexpand: Defmacro.
* delim: Precedence Parsing Overview.
+* diff: Sequence Comparison. |
* 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.
@@ -10972,7 +12206,7 @@ Concept and Feature Index
* fft: Fast Fourier Transform.
* fluid-let <1>: Database Utilities.
* fluid-let: Fluid-Let.
-* form: HTML HTTP and CGI.
+* form: HTML.
* format: Format.
* generic-write: Generic-Write.
* getit: System Interface.
@@ -10980,16 +12214,20 @@ Concept and Feature Index
* getopt: Getopt.
* glob <1>: Batch.
* glob: Filenames.
+* Guile: Installation. |
* hash: Hashing.
* hash-table: Hash Tables.
* HOME <1>: Vicinity.
* HOME: Library Catalogs.
* homecat: Catalog Compilation.
+* html-form: HTML. |
+* http: HTTP and CGI. |
* implcat: Catalog Compilation.
* infix: Precedence Parsing Overview.
* inmatchfix: Precedence Parsing Overview.
* Left Denotation, led: Nud and Led Definition.
* line-i: Line I/O.
+* list-processing library: SRFI-1. |
* logical: Bit-Twiddling.
* macro <1>: Repl.
* macro: R4RS Macros.
@@ -10997,33 +12235,40 @@ Concept and Feature Index
* macros-that-work: Macros That Work.
* make-crc: Cyclic Checksum.
* match: Base Table.
-* match-key: Base Table.
-* match-keys: Table Operations.
+* 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.
+* MIT Scheme: Installation. |
* 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. |
+* options file: Command Line.
* parameters <1>: Database Utilities.
* parameters <2>: Batch.
* parameters: Parameter lists.
* parse: Precedence Parsing.
-* plain-text: HTML HTTP and CGI.
+* plain-text: HTML.
+* PLT Scheme: Installation.
* posix-time: Posix Time.
* postfix: Precedence Parsing Overview.
* pprint-file: Pretty-Print.
-* PRE: HTML HTTP and CGI.
+* PRE: HTML.
* precedence: Precedence Parsing.
* precision (printf): Standard Formatted Output.
* prefix: Precedence Parsing Overview.
@@ -11037,7 +12282,7 @@ Concept and Feature Index
* promise: Promises.
* qp <1>: Quick Print.
* qp: Getopt.
-* query-string: HTML HTTP and CGI.
+* query-string: HTTP and CGI.
* queue: Queues.
* random: Random Numbers.
* rationalize: Rationalize.
@@ -11046,27 +12291,37 @@ Concept and Feature Index
* relational-database: Relational Database.
* repl <1>: Repl.
* repl: Syntax-Case Macros.
+* reset: HTML.
* rev2-procedures: Rev2 Procedures.
-* rev3-report: Coding Standards.
+* 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. |
+* scanf: Standard Formatted Input.
+* Scheme Request For Implementation: SRFI. |
+* Scheme48: Installation.
* schmooz: Schmooz.
+* SCM: Installation.
+* self-set: Commutative Rings. |
+* Sequence Comparison: Sequence Comparison. |
+* Server-based Naming Authority: URI.
* session: Feature.
* sets, using binary trees: Weight-Balanced Trees.
* sierpinski: Hashing.
-* sitecat: Catalog Compilation. |
+* sitecat: Catalog Compilation.
* slibcat: Catalog Compilation.
* sort: Sorting.
* soundex: Hashing.
+* spiff: Sequence Comparison. |
+* srfi: SRFI. |
+* SRFI-1: SRFI-1. |
+* srfi-1: SRFI-1. |
* stdio: Standard Formatted I/O.
* string-case: String-Case.
* string-port: String Ports.
-* string-search: String Search.
-* struct: Structures.
+* string-search: String Search. |
* syntactic-closures: Syntactic Closures.
* syntax-case: Syntax-Case Macros.
* time: Time and Date.
@@ -11078,11 +12333,16 @@ Concept and Feature Index
* 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: 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.
@@ -11092,149 +12352,162 @@ Concept and Feature Index

Tag Table:
-Node: Top1057
-Node: The Library System1870
-Node: Feature2184
-Node: Requesting Features3134
-Node: Library Catalogs4493
-Node: Catalog Compilation6945
-Node: Built-in Support9755
-Node: Require10386
-Node: Vicinity12879
-Node: Configuration15846
-Node: Input/Output18787
-Node: Legacy20386
-Node: System21228
-Node: About this manual23720
-Node: Scheme Syntax Extension Packages24277
-Node: Defmacro24962
-Node: R4RS Macros26912
-Node: Macro by Example28167
-Node: Macros That Work31043
-Node: Syntactic Closures37101
-Node: Syntax-Case Macros54534
-Node: Fluid-Let58661
-Node: Yasos59602
-Node: Yasos terms60395
-Node: Yasos interface61419
-Node: Setters63496
-Node: Yasos examples66138
-Node: Textual Conversion Packages69132
-Node: Precedence Parsing69708
-Node: Precedence Parsing Overview70371
-Node: Ruleset Definition and Use72572
-Node: Token definition74953
-Node: Nud and Led Definition77222
-Node: Grammar Rule Definition79671
-Node: Format87245
-Node: Format Interface87493
-Node: Format Specification89230
-Node: Standard Formatted I/O99287
-Node: Standard Formatted Output99853
-Node: Standard Formatted Input108913
-Node: Programs and Arguments115572
-Node: Getopt116085
-Node: Command Line121927
-Node: Parameter lists125116
-Node: Getopt Parameter lists128753
-Node: Filenames130948
-Node: Batch134178
-Node: HTML HTTP and CGI142791
-Node: Printing Scheme149960
-Node: Generic-Write150283
-Node: Object-To-String151686
-Node: Pretty-Print152090
-Node: Time and Date154036
-Node: Time Zone155063
-Node: Posix Time159625
-Node: Common-Lisp Time161761
-Node: Vector Graphics163340
-Node: Tektronix Graphics Support163529
-Node: Schmooz164903
-Node: Mathematical Packages169129
-Node: Bit-Twiddling169721
-Node: Modular Arithmetic174312
-Node: Prime Numbers176446
-Node: Random Numbers178453
-Node: Fast Fourier Transform183166
-Node: Cyclic Checksum184084
-Node: Plotting185802
-Node: Root Finding188377
-Node: Commutative Rings192371
-Node: Determinant203757
-Node: Database Packages204055
-Node: Base Table204319
-Node: Relational Database214477
-Node: Motivations215261
-Node: Creating and Opening Relational Databases220308
-Node: Relational Database Operations222740
-Node: Table Operations225537
-Node: Catalog Representation233415
-Node: Unresolved Issues236313
-Node: Database Utilities239264
-Node: Database Reports254919
-Node: Database Browser257674
-Node: Weight-Balanced Trees258735
-Node: Construction of Weight-Balanced Trees262605
-Node: Basic Operations on Weight-Balanced Trees266055
-Node: Advanced Operations on Weight-Balanced Trees269020
-Node: Indexing Operations on Weight-Balanced Trees275042
-Node: Other Packages278956
-Node: Data Structures279355
-Node: Arrays280074
-Node: Array Mapping283028
-Node: Association Lists284945
-Node: Byte287196
-Node: Collections289427
-Node: Dynamic Data Type295534
-Node: Hash Tables296795
-Node: Hashing298912
-Node: Object303687
-Node: Priority Queues311924
-Node: Queues312767
-Node: Records313893
-Node: Structures317404
-Node: Procedures318704
-Node: Common List Functions319391
-Node: List construction319815
-Node: Lists as sets321478
-Node: Lists as sequences326850
-Node: Destructive list operations332096
-Node: Non-List functions334760
-Node: Tree Operations336108
-Node: Chapter Ordering337654
-Node: Sorting339274
-Node: Topological Sort345051
-Node: String-Case346738
-Node: String Ports347359
-Node: String Search348123
-Node: Line I/O350490
-Node: Multi-Processing352139
-Node: Standards Support353223
-Node: With-File353878
-Node: Transcripts354154
-Node: Rev2 Procedures354475
-Node: Rev4 Optional Procedures356182
-Node: Multi-argument / and -356752
-Node: Multi-argument Apply357403
-Node: Rationalize357889
-Node: Promises358552
-Node: Dynamic-Wind358969
-Node: Eval360223
-Node: Values363560
-Node: Session Support364347
-Node: Repl364815
-Node: Quick Print366098
-Node: Debug367211
-Node: Breakpoints367853
-Node: Trace370071
-Node: System Interface371445
-Node: Extra-SLIB Packages375246
-Node: About SLIB377378
-Node: Installation378462
-Node: Porting380312
-Node: Coding Standards381829
-Node: Copyrights383908
-Node: Index387192
+Node: Top1026
+Node: The Library System1740
+Node: Feature2054
+Node: Requesting Features3004
+Node: Library Catalogs4363
+Node: Catalog Compilation6815
+Node: Built-in Support9624
+Node: Require10255
+Node: Vicinity12747
+Node: Configuration15714
+Node: Input/Output18655
+Node: Legacy20254
+Node: System21096
+Node: About this manual23588
+Node: Scheme Syntax Extension Packages24145
+Node: Defmacro24837
+Node: R4RS Macros26788
+Node: Macro by Example28043
+Node: Macros That Work30922
+Node: Syntactic Closures36980
+Node: Syntax-Case Macros54414
+Node: Fluid-Let58605
+Node: Yasos59546
+Node: Yasos terms60339
+Node: Yasos interface61363
+Node: Setters63438
+Node: Yasos examples66079
+Node: Textual Conversion Packages69073
+Node: Precedence Parsing69751
+Node: Precedence Parsing Overview70414
+Ref: Precedence Parsing Overview-Footnote-172337
+Node: Ruleset Definition and Use72615
+Node: Token definition74996
+Node: Nud and Led Definition77265
+Node: Grammar Rule Definition79714
+Node: Format87288
+Node: Format Interface87536
+Node: Format Specification89273
+Node: Standard Formatted I/O99328
+Node: Standard Formatted Output99894
+Node: Standard Formatted Input109617
+Node: Programs and Arguments116277
+Node: Getopt116777
+Node: Command Line122619
+Node: Parameter lists125808
+Node: Getopt Parameter lists129695
+Node: Filenames132950
+Node: Batch136180
+Node: HTML143973
+Node: HTML Tables150074
+Node: HTTP and CGI156483
+Node: URI161013
+Node: Printing Scheme163686
+Node: Generic-Write163995
+Node: Object-To-String165398
+Node: Pretty-Print165802
+Node: Time and Date168765
+Node: Time Zone169792
+Node: Posix Time174353
+Node: Common-Lisp Time176489
+Node: Vector Graphics178068
+Node: Tektronix Graphics Support178257
+Node: Schmooz179631
+Node: Mathematical Packages183857
+Node: Bit-Twiddling184491
+Node: Modular Arithmetic189082
+Node: Prime Numbers191216
+Node: Random Numbers192899
+Node: Fast Fourier Transform197535
+Node: Cyclic Checksum198453
+Node: Plotting200417
+Node: Root Finding203276
+Node: Minimizing207263
+Ref: Minimizing-Footnote-1208700
+Node: Commutative Rings209303
+Node: Determinant220687
+Node: Database Packages221092
+Node: Base Table221356
+Node: Relational Database231770
+Node: Motivations232554
+Node: Creating and Opening Relational Databases237601
+Node: Relational Database Operations240033
+Node: Table Operations243029
+Node: Catalog Representation250907
+Node: Unresolved Issues253805
+Node: Database Utilities256756
+Node: Database Reports272873
+Node: Database Browser275627
+Node: Weight-Balanced Trees276688
+Node: Construction of Weight-Balanced Trees280559
+Node: Basic Operations on Weight-Balanced Trees284009
+Node: Advanced Operations on Weight-Balanced Trees286974
+Node: Indexing Operations on Weight-Balanced Trees292996
+Node: Other Packages296910
+Node: Data Structures297389
+Node: Arrays298223
+Node: Array Mapping302100
+Node: Association Lists304017
+Node: Byte306268
+Node: Portable Image Files308508
+Node: Collections310055
+Node: Dynamic Data Type316447
+Node: Hash Tables317708
+Node: Hashing319889
+Node: Object324660
+Node: Priority Queues332896
+Node: Queues333739
+Node: Records334865
+Node: Sorting and Searching338436
+Node: Common List Functions339236
+Node: List construction339761
+Node: Lists as sets341607
+Node: Lists as sequences348573
+Node: Destructive list operations353827
+Node: Non-List functions356490
+Node: Tree Operations357667
+Node: Chapter Ordering359507
+Node: Sorting361217
+Node: Topological Sort367084
+Node: String Search368863
+Node: Sequence Comparison371335
+Node: Procedures377271
+Node: Type Coercion378665
+Node: String-Case379881
+Node: String Ports382059
+Node: Line I/O383592
+Node: Multi-Processing385320
+Node: Metric Units386424
+Node: Standards Support394650
+Node: With-File395385
+Node: Transcripts395661
+Node: Rev2 Procedures395982
+Node: Rev4 Optional Procedures397739
+Node: Multi-argument / and -398309
+Node: Multi-argument Apply399048
+Node: Rationalize399583
+Node: Promises400908
+Node: Dynamic-Wind401325
+Node: Eval402579
+Node: Values405916
+Node: SRFI406795
+Node: SRFI-1409905
+Node: Session Support420362
+Node: Repl420909
+Node: Quick Print422192
+Node: Debug423305
+Node: Breakpoints424191
+Node: Trace426214
+Node: System Interface429325
+Node: Extra-SLIB Packages433079
+Node: About SLIB435381
+Node: Installation436084
+Node: Porting443977
+Ref: Porting-Footnote-1421798
+Node: Coding Guidelines445504
+Node: Copyrights447585
+Node: Index450931

End Tag Table
diff --git a/slib.spec b/slib.spec
new file mode 100644
index 0000000..38e425a
--- /dev/null
+++ b/slib.spec
@@ -0,0 +1,97 @@
+%define name slib
+%define version 2d2
+%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 <agj @ alum.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 type guile; then
+ guile -c "(use-modules (ice-9 slib)) (require 'new-catalog)"
+fi
+if type scm; then
+ scm -c "(require 'new-catalog)"
+fi
+if type umb-scheme; then
+ SCHEME_INIT=${SCHEME_LIBRARY_PATH}umbscheme.init
+ echo "(require 'new-catalog)" | umb-scheme
+fi
+if type mzscheme; then
+ SCHEME_LIBRARY_PATH=`pwd`/
+ rm /usr/local/lib/plt-103/slibcat
+ mzscheme -L init.ss slibinit -e "(require 'new-catalog)"
+fi
+if type scheme48; then
+ make install48
+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 README COPYING FAQ ChangeLog
+
+%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 <agj @ alum.mit.edu>
+- Updated content
diff --git a/slib.texi b/slib.texi
index dacf3c6..3acaa14 100644
--- a/slib.texi
+++ b/slib.texi
@@ -27,7 +27,7 @@
This file documents SLIB, the portable Scheme library.
Copyright (C) 1993 Todd R. Eigenschink@*
-Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999 Aubrey Jaffer
+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
@@ -74,7 +74,7 @@ you!
@sp 1
@quotation
SLIB @value{SLIBVERSION}, released @value{SLIBDATE}.@*
-Aubrey Jaffer <jaffer @@ ai.mit.edu>@*
+Aubrey Jaffer <agj @@ alum.mit.edu>@*
@ifset html
<A HREF="http://swissnet.ai.mit.edu/~jaffer/SLIB.html">
@end ifset
@@ -87,7 +87,7 @@ Aubrey Jaffer <jaffer @@ ai.mit.edu>@*
@ifclear html
@vskip 0pt plus 1filll
Copyright @copyright{} 1993 Todd R. Eigenschink@*
-Copyright @copyright{} 1993, 1994, 1995, 1996, 1997, 1998, 1999 Aubrey Jaffer
+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
@@ -346,6 +346,7 @@ 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
@@ -469,12 +470,12 @@ should be either a string or a list.
@noindent
In the following functions if the argument @var{feature} is not a symbol
-it is assumed to be a pathname.@refill
+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.@refill
+loaded and @code{#f} otherwise.
@end defun
@deffn Procedure require feature
@@ -493,7 +494,7 @@ unspecified value is returned.
@deffn Procedure provide feature
Assures that @var{feature} is contained in @code{*features*} if
-@var{feature} is a symbol and @code{*modules*} otherwise.@refill
+@var{feature} is a symbol and @code{*modules*} otherwise.
@end deffn
@defun require:feature->path feature
@@ -535,7 +536,7 @@ 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}.@refill
+@code{load}.
@end defun
@defun library-vicinity
@@ -563,7 +564,7 @@ returns @code{#f}.
@c @defun scheme-file-suffix
@c Returns the default filename suffix for scheme source files. On most
-@c systems this is @samp{.scm}.@refill
+@c systems this is @samp{.scm}.
@c @end defun
@defun in-vicinity vicinity filename
@@ -576,7 +577,7 @@ an absolute pathname and @var{vicinity} is equal to the value of
@code{(user-vicinity)}. The behavior of @code{in-vicinity} when
@var{filename} is absolute and @var{vicinity} is not equal to the value
of @code{(user-vicinity)} is unspecified. For most systems
-@code{in-vicinity} can be @code{string-append}.@refill
+@code{in-vicinity} can be @code{string-append}.
@end defun
@defun sub-vicinity vicinity name
@@ -584,7 +585,7 @@ Returns the vicinity of @var{vicinity} restricted to @var{name}. This
is used for large systems where names of files in subsystems could
conflict. On systems with directory structure @code{sub-vicinity} will
return a pathname of the subdirectory @var{name} of
-@var{vicinity}.@refill
+@var{vicinity}.
@end defun
@@ -599,7 +600,7 @@ implementations.
@defvr Constant char-code-limit
An integer 1 larger that the largest value which can be returned by
-@code{char->integer}.@refill
+@code{char->integer}.
@end defvr
@defvr Constant most-positive-fixnum
@@ -632,7 +633,7 @@ 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
+(slib:report-version) @result{} slib "@value{SLIBVERSION}" on scm "5b1" on unix
@end example
@end defun
@@ -650,15 +651,15 @@ 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* :
+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* :
+implementation *features* :
bignum complex real rational
inexact vicinity ed getenv
tmpnam abort transcript with-file
@@ -669,9 +670,9 @@ implementation *features* :
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")
- ...
+implementation *catalog* :
+ (i/o-extensions compiled "/home/jaffer/scm/ioext.so")
+ ...
@end example
@end defun
@@ -690,13 +691,13 @@ feature then @code{#f} is always returned.
@deffn Procedure delete-file filename
Deletes the file specified by @var{filename}. If @var{filename} can not
be deleted, @code{#f} is returned. Otherwise, @code{#t} is
-returned.@refill
+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.@refill
+pathnames.
@end deffn
@deffn Procedure current-error-port
@@ -709,7 +710,7 @@ directed.
Forces any pending output on @var{port} to be delivered to the output
device and returns an unspecified value. The @var{port} argument may be
omitted, in which case it defaults to the value returned by
-@code{(current-output-port)}.@refill
+@code{(current-output-port)}.
@end deffn
@deffn Procedure output-port-width
@@ -717,7 +718,7 @@ omitted, in which case it defaults to the value returned by
Returns the width of @var{port}, which defaults to
@code{(current-output-port)} if absent. If the width cannot be
-determined 79 is returned.@refill
+determined 79 is returned.
@end deffn
@deffn Procedure output-port-height
@@ -725,7 +726,7 @@ determined 79 is returned.@refill
Returns the height of @var{port}, which defaults to
@code{(current-output-port)} if absent. If the height cannot be
-determined 24 is returned.@refill
+determined 24 is returned.
@end deffn
@node Legacy, System, Input/Output, Built-in Support
@@ -812,7 +813,7 @@ facility.
the Scheme source code expressions and definitions are read from the
file and @var{eval} called with them sequentially. The
@code{slib:eval-load} procedure does not affect the values returned by
-@code{current-input-port} and @code{current-output-port}.@refill
+@code{current-input-port} and @code{current-output-port}.
@end deffn
@deffn Procedure slib:warn arg1 arg2 @dots{}
@@ -823,7 +824,7 @@ Outputs a warning message containing the arguments.
Outputs an error message containing the arguments, aborts evaluation of
the current form and responds in a system dependent way to the error.
Typical responses are to abort the program or to enter a read-eval-print
-loop.@refill
+loop.
@end deffn
@deffn Procedure slib:exit n
@@ -870,7 +871,7 @@ using the package.
* Syntactic Closures:: 'syntactic-closures
* Syntax-Case Macros:: 'syntax-case
-Syntax extensions (macros) included with SLIB. Also @xref{Structures}.
+Syntax extensions (macros) included with SLIB.
* Fluid-Let:: 'fluid-let
* Yasos:: 'yasos, 'oop, 'collect
@@ -904,7 +905,7 @@ and definitions from the file and evaluates them sequentially. These
source code expressions and definitions may contain defmacro
definitions. The @code{macro:load} procedure does not affect the values
returned by @code{current-input-port} and
-@code{current-output-port}.@refill
+@code{current-output-port}.
@end defun
@defun defmacro? sym
@@ -917,7 +918,7 @@ Returns @code{#t} if @var{sym} has been defined by @code{defmacro},
If @var{form} is a macro call, @code{macroexpand-1} will expand the
macro call once and return it. A @var{form} is considered to be a macro
call only if it is a cons whose @code{car} is a symbol for which a
-@code{defmacr} has been defined.
+@code{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.
@@ -967,7 +968,7 @@ the @code{macro:load} procedure reads Scheme source code expressions and
definitions from the file and evaluates them sequentially. These source
code expressions and definitions may contain macro definitions. The
@code{macro:load} procedure does not affect the values returned by
-@code{current-input-port} and @code{current-output-port}.@refill
+@code{current-input-port} and @code{current-output-port}.
@end deffn
@node Macro by Example, Macros That Work, R4RS Macros, Scheme Syntax Extension Packages
@@ -977,7 +978,7 @@ code expressions and definitions may contain macro definitions. The
@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}.
+R4RS) by Dorai Sitaram, (dorai @@ cs.rice.edu) using @code{defmacro}.
@itemize @bullet
@@ -1072,7 +1073,7 @@ the macro expansion.
@code{macro:eval} returns the value of @var{expression} in the current
top level environment. @var{expression} can contain macro definitions.
Side effects of @var{expression} will affect the top level
-environment.@refill
+environment.
@end defun
@deffn Procedure macro:load filename
@@ -1082,7 +1083,7 @@ the @code{macro:load} procedure reads Scheme source code expressions and
definitions from the file and evaluates them sequentially. These source
code expressions and definitions may contain macro definitions. The
@code{macro:load} procedure does not affect the values returned by
-@code{current-input-port} and @code{current-output-port}.@refill
+@code{current-input-port} and @code{current-output-port}.
@end deffn
References:
@@ -1090,7 +1091,7 @@ References:
The @cite{Revised^4 Report on the Algorithmic Language Scheme} Clinger
and Rees [editors]. To appear in LISP Pointers. Also available as a
technical report from the University of Oregon, MIT AI Lab, and
-Cornell.@refill
+Cornell.
@center Macros That Work. Clinger and Rees. POPL '91.
@@ -1254,7 +1255,7 @@ unnecessarily. That shouldn't matter very often.
@defun macro:expand expression
@defunx synclo:expand expression
Returns scheme code with the macros and derived expression types of
-@var{expression} expanded to primitive expression types.@refill
+@var{expression} expanded to primitive expression types.
@end defun
@defun macro:eval expression
@@ -1262,7 +1263,7 @@ Returns scheme code with the macros and derived expression types of
@code{macro:eval} returns the value of @var{expression} in the current
top level environment. @var{expression} can contain macro definitions.
Side effects of @var{expression} will affect the top level
-environment.@refill
+environment.
@end defun
@deffn Procedure macro:load filename
@@ -1272,7 +1273,7 @@ the @code{macro:load} procedure reads Scheme source code expressions and
definitions from the file and evaluates them sequentially. These
source code expressions and definitions may contain macro definitions.
The @code{macro:load} procedure does not affect the values returned by
-@code{current-input-port} and @code{current-output-port}.@refill
+@code{current-input-port} and @code{current-output-port}.
@end deffn
@subsection Syntactic Closure Macro Facility
@@ -1306,7 +1307,7 @@ The description of the facility is divided into three parts. The first
part defines basic terminology. The second part describes how macro
transformers are defined. The third part describes the use of
@dfn{identifiers}, which extend the syntactic closure mechanism to be
-compatible with @code{syntax-rules}.@refill
+compatible with @code{syntax-rules}.
@subsubsection Terminology
@@ -1335,7 +1336,7 @@ define
appear anywhere in a form that the symbol could be used, and when quoted
it is replaced by the symbol; however, it does not satisfy the predicate
@code{symbol?}. Macro transformers rarely distinguish symbols from
-aliases, referring to both as identifiers.@refill
+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
@@ -1344,7 +1345,7 @@ interpretation for the form in which that keyword appears. If it is a
variable, the meaning identifies which binding of that variable is
referenced. In short, syntactic environments contain all of the
contextual information necessary for interpreting the meaning of a
-particular form.@refill
+particular form.
@item A @dfn{syntactic closure} consists of a form, a syntactic
environment, and a list of identifiers. All identifiers in the form
@@ -1355,7 +1356,7 @@ which its form could have been used. Since a syntactic closure is also
a form, it may not be used in contexts where a form would be illegal.
For example, a form may not appear as a clause in the cond special form.
A syntactic closure appearing in a quoted structure is replaced by its
-form.@refill
+form.
@end itemize
@@ -1363,18 +1364,18 @@ form.@refill
This section describes the @code{transformer} special form and the
procedures @code{make-syntactic-closure} and
-@code{capture-syntactic-environment}.@refill
+@code{capture-syntactic-environment}.
@deffn Syntax transformer expression
Syntax: It is an error if this syntax occurs except as a
-@var{transformer spec}.@refill
+@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}).@refill
+@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
@@ -1383,7 +1384,7 @@ occurred. The second argument, the @dfn{usage environment}, is the
syntactic environment in which the input form occurred. The result of
the transformer, the @dfn{output form}, is automatically closed in the
@dfn{transformer environment}, which is the syntactic environment in
-which the @code{transformer} expression occurred.@refill
+which the @code{transformer} expression occurred.
For example, here is a definition of a push macro using
@code{syntax-rules}:@refill
@@ -1409,7 +1410,7 @@ Here is an equivalent definition using @code{transformer}:
In this example, the identifiers @code{set!} and @code{cons} are closed
in the transformer environment, and thus will not be affected by the
meanings of those identifiers in the usage environment
-@code{env}.@refill
+@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
@@ -1433,7 +1434,7 @@ be left free when the body is closed:@refill
To assign meanings to the identifiers in a form, use
@code{make-syntactic-closure} to close the form in a syntactic
-environment.@refill
+environment.
@end deffn
@defun make-syntactic-closure environment free-names form
@@ -1444,13 +1445,13 @@ be a list of identifiers, and @var{form} must be a form.
of @var{form} in @var{environment}, which can be used anywhere that
@var{form} could have been used. All the identifiers used in
@var{form}, except those explicitly excepted by @var{free-names}, obtain
-their meanings from @var{environment}.@refill
+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.@refill
+free.
@lisp
(define-syntax let1
(transformer
@@ -1468,10 +1469,10 @@ single identifier, and whose body consists of a single expression. When
the body expression is syntactically closed in its original syntactic
environment, the identifier that is to be bound by @code{let1} must be
left free, so that it can be properly captured by the @code{lambda} in
-the output form.@refill
+the output form.
To obtain a syntactic environment other than the usage environment, use
-@code{capture-syntactic-environment}.@refill
+@code{capture-syntactic-environment}.
@end defun
@defun capture-syntactic-environment procedure
@@ -1479,7 +1480,7 @@ To obtain a syntactic environment other than the usage environment, use
@code{capture-syntactic-environment} returns a form that will, when
transformed, call @var{procedure} on the current syntactic environment.
@var{procedure} should compute and return a new form to be transformed,
-in that same syntactic environment, in place of the form.@refill
+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
@@ -1522,7 +1523,7 @@ that it will be captured by the binding introduced by the @code{lambda}
expression. Unfortunately it uses the identifiers @code{if} and
@code{loop} within that @code{lambda} expression, so if the user of
@code{loop-until} just happens to use, say, @code{if} for the
-identifier, it will be inadvertently captured.@refill
+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
@@ -1558,7 +1559,7 @@ as follows:@refill
In this case, having captured the desired syntactic environment, it is
convenient to construct syntactic closures of the identifiers @code{if}
and the @code{loop} and use them in the body of the
-@code{lambda}.@refill
+@code{lambda}.
A common use of @code{capture-syntactic-environment} is to get the
transformer environment of a macro transformer:@refill
@@ -1577,7 +1578,7 @@ This section describes the procedures that create and manipulate
identifiers. Previous syntactic closure proposals did not have an
identifier data type -- they just used symbols. The identifier data
type extends the syntactic closures facility to be compatible with the
-high-level @code{syntax-rules} facility.@refill
+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
@@ -1592,7 +1593,7 @@ like syntactic closures most of the time. The difference is that an
alias may be bound to a new value (for example by @code{lambda} or
@code{let-syntax}); other syntactic closures may not be used this way.
If an alias is bound, then within the scope of that binding it is looked
-up in the syntactic environment just like any other identifier.@refill
+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}
@@ -1637,7 +1638,7 @@ the final clause in the conditional. A macro transformer for
replaced the symbol @code{else} with an alias. Instead the transformer
must look for an identifier that ``means the same thing'' in the usage
environment as the symbol @code{else} means in the transformer
-environment.@refill
+environment.
@end defun
@defun identifier=? environment1 identifier1 environment2 identifier2
@@ -1684,7 +1685,7 @@ The syntactic closures facility was invented by Alan Bawden and Jonathan
Rees. The use of aliases to implement @code{syntax-rules} was invented
by Alan Bawden (who prefers to call them @dfn{synthetic names}). Much
of this proposal is derived from an earlier proposal by Alan
-Bawden.@refill
+Bawden.
@@ -1699,7 +1700,7 @@ Bawden.@refill
@defun macro:expand expression
@defunx syncase:expand expression
Returns scheme code with the macros and derived expression types of
-@var{expression} expanded to primitive expression types.@refill
+@var{expression} expanded to primitive expression types.
@end defun
@defun macro:eval expression
@@ -1707,7 +1708,7 @@ Returns scheme code with the macros and derived expression types of
@code{macro:eval} returns the value of @var{expression} in the current
top level environment. @var{expression} can contain macro definitions.
Side effects of @var{expression} will affect the top level
-environment.@refill
+environment.
@end defun
@deffn Procedure macro:load filename
@@ -1717,14 +1718,14 @@ the @code{macro:load} procedure reads Scheme source code expressions and
definitions from the file and evaluates them sequentially. These
source code expressions and definitions may contain macro definitions.
The @code{macro:load} procedure does not affect the values returned by
-@code{current-input-port} and @code{current-output-port}.@refill
+@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
+<hanche @@ imf.unit.no> to make it compatible with, and easily usable
with, SLIB. Mainly, these adaptations consisted of:
@itemize @bullet
@@ -1755,7 +1756,7 @@ distribution with them. If you do intend to use @code{syntax-case},
however, you should get these files and print them out on a PostScript
printer. They are available with the original @code{syntax-case}
distribution by anonymous FTP in
-@file{cs.indiana.edu:/pub/scheme/syntax-case}.@refill
+@file{cs.indiana.edu:/pub/scheme/syntax-case}.
In order to use syntax-case from an interactive top level, execute:
@lisp
@@ -1783,14 +1784,14 @@ Gambit).
All R4RS syntactic forms are defined, including @code{delay}. Along
with @code{delay} are simple definitions for @code{make-promise} (into
-which @code{delay} expressions expand) and @code{force}.@refill
+which @code{delay} expressions expand) and @code{force}.
@code{syntax-rules} and @code{with-syntax} (described in @cite{TR356})
-are defined.@refill
+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.@refill
+@code{syntax-lambda}; do not redefine these names.
Several other top-level bindings not documented in TR356 are created:
@itemize @bullet
@@ -1800,14 +1801,14 @@ Several other top-level bindings not documented in TR356 are created:
@end itemize
The syntax of define has been extended to allow @code{(define @var{id})},
-which assigns @var{id} to some unspecified value.@refill
+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.@refill
+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).
+(dyb @@ iuvax.cs.indiana.edu).
@subsection Note from maintainer
@@ -1833,14 +1834,14 @@ unspecified order), the current values of the @var{variable}s are saved,
the results are assigned to the @var{variable}s, the @var{expression}s
are evaluated sequentially in the current environment, the
@var{variable}s are restored to their original values, and the value of
-the last @var{expression} is returned.@refill
+the 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}.@refill
+@var{variable}.
@node Yasos, , Fluid-Let, Scheme Syntax Extension Packages
@@ -1857,7 +1858,7 @@ by the rules of lexical scoping) of its corresponding
`Yet Another Scheme Object System' is a simple object system for Scheme
based on the paper by Norman Adams and Jonathan Rees: @cite{Object
Oriented Programming in Scheme}, Proceedings of the 1988 ACM Conference
-on LISP and Functional Programming, July 1988 [ACM #552880].@refill
+on LISP and Functional Programming, July 1988 [ACM #552880].
Another reference is:
@@ -1901,12 +1902,12 @@ first ancestor which contains it (in the ancestor @code{let}). An
operation may be applied to any Scheme data object---not just instances.
As code which creates instances is just code, there are no @dfn{classes}
and no meta-@var{anything}. Method dispatch is by a procedure call a la
-CLOS rather than by @code{send} syntax a la Smalltalk.@refill
+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.@refill
+reasonable). See the L&FP paper for some suggestions.
@end table
@@ -1919,21 +1920,21 @@ reasonable). See the L&FP paper for some suggestions.@refill
@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.@refill
+@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.@refill
+@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{}.@refill
+with argument(s) @var{arg}@dots{}.
@end deffn
@deffn Syntax object-with-ancestors @code{((}ancestor1 init1@code{)} @dots{}@code{)} operation @dots{}
@@ -1948,7 +1949,7 @@ ancestor in the ancestor list.
@deffn Syntax operate-as component operation self arg @dots{}
Used in an operation definition (of @var{self}) to invoke the
@var{operation} in an ancestor @var{component} but maintain the object's
-identity. Also known as ``send-to-super''.@refill
+identity. Also known as ``send-to-super''.
@end deffn
@deffn Procedure print obj port
@@ -1961,7 +1962,7 @@ A default @code{print} operation is provided which is just @code{(format
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.@refill
+(@pxref{Collections}) may override the default in an obvious way.
@end defun
@@ -2143,7 +2144,10 @@ value is unspecified.
* Format:: Common-Lisp Format
* Standard Formatted I/O:: Posix printf and scanf
* Programs and Arguments::
-* HTML HTTP and CGI:: Generate pages and serve WWW sites
+* HTML::
+* HTML Tables:: Databases meet HTML
+* HTTP and CGI:: Serve WWW sites
+* URI:: Uniform Resource Identifier
* Printing Scheme:: Nicely
* Time and Date::
* Vector Graphics::
@@ -2762,7 +2766,7 @@ An output conversion specifications consist of an initial @samp{%}
character followed in sequence by:
@itemize @bullet
-@item
+@item
Zero or more @dfn{flag characters} that modify the normal behavior of
the conversion specification.
@@ -2804,7 +2808,7 @@ flag is also specified, or if a precision is specified for an exact
converson.
@end table
-@item
+@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
@@ -2818,7 +2822,7 @@ 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
+@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
@@ -2864,6 +2868,12 @@ A character that specifies the conversion to be applied.
@subsubsection Exact Conversions
@table @asis
+@item @samp{b}, @samp{B}
+Print an integer as an unsigned binary number.
+
+@emph{Note:} @samp{%b} and @samp{%B} are SLIB extensions.
+
+
@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}
@@ -2894,10 +2904,16 @@ 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.
+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
@@ -2935,7 +2951,7 @@ are output.
@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
+error to specify flags, field width, precision, or type modifiers with
@samp{%%}.
@end table
@end deffn
@@ -3110,7 +3126,7 @@ left unread in the input stream.
@end defmac
-@node Programs and Arguments, HTML HTTP and CGI, Standard Formatted I/O, Textual Conversion Packages
+@node Programs and Arguments, HTML, Standard Formatted I/O, Textual Conversion Packages
@section Program and Arguments
@menu
@@ -3242,7 +3258,7 @@ Example:
@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}.
+@samp{--hold-the-onions} and @samp{--verbosity-level=extreme}.
@w{@code{Getopt--}} behaves as @code{getopt} except for non-empty
options beginning with @samp{--}.
@@ -3270,11 +3286,11 @@ errors.
(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"
+2 #\b "9"
+3 "f1" #f
+4 "2" ""
+5 "g3" "35234.342"
+5 #f "35234.342"
@end example
@end defun
@@ -3393,6 +3409,15 @@ Returns an empty parameter-list with slots for @var{parameter-names}.
@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
@@ -3425,7 +3450,7 @@ which created @var{parameter-list}.
@code{check-parameters} returns @var{parameter-list} if each @var{check}
of the corresponding @var{parameter-list} returns non-false. If some
-@var{check} returns @code{#f} an error is signaled.
+@var{check} returns @code{#f} a warning is signaled.
@end deffn
@noindent
@@ -3445,11 +3470,11 @@ Any number of parameters are acceptable.
One or more of parameters are acceptable.
@end table
-@deffn Function parameter-list->arglist positions arities types parameter-list
+@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) of type @var{types}.
+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
@@ -3464,19 +3489,38 @@ should appear.
@code{(require 'getopt-parameters)}
-@deffn Function getopt->parameter-list argc argv optnames arities types aliases
+@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{aliases} is a list of lists of strings and
-elements of @var{optnames}. Each of these strings which have length of
-1 will be treated as a single @key{-} option by @code{getopt}. Longer
-strings will be treated as long-named options (@pxref{Getopt, getopt--}).
+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
+@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}.
+@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
@@ -3486,7 +3530,8 @@ make-command-server}.
@noindent
If errors are encountered while processing options, directions for using
-the options are printed to @code{current-error-port}.
+the options (and argument strings @var{desc} @dots{}) are printed to
+@code{current-error-port}.
@example
(begin
@@ -3514,19 +3559,20 @@ the options are printed to @code{current-error-port}.
@print{}
Usage: cmd [OPTION ARGUMENT ...] ...
- -f, --flag
- -o, --optional=<number>
+ -f, --flag
+ -o, --optional=<number>
-n, --nary=<symbols> ...
-N, --nary1=<symbols> ...
- -s, --single=<string>
- --Flag
- -B
+ -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
@@ -3867,13 +3913,32 @@ hello world
@end example
-@node HTML HTTP and CGI, Printing Scheme, Programs and Arguments, Textual Conversion Packages
-@section HTML Forms
+@node HTML, HTML Tables, Programs and Arguments, Textual Conversion Packages
+@section HTML
@include htmlform.txi
-@node Printing Scheme, Time and Date, HTML HTTP and CGI, Textual Conversion Packages
+@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
@@ -3893,7 +3958,7 @@ hello world
(or Scheme program expression) into its textual representation and
prints it. The interface to the procedure is sufficiently general to
easily implement other useful formatting procedures such as pretty
-printing, output to a string and truncated output.@refill
+printing, output to a string and truncated output.
@deffn Procedure generic-write obj display? width output
@table @var
@@ -3967,6 +4032,53 @@ Example:
@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
@@ -3975,7 +4087,7 @@ Example:
@deffnx Procedure pprint-file infile outfile
Pretty-prints all the code in @var{infile}. If @var{outfile} is
specified, the output goes to @var{outfile}, otherwise it goes to
-@code{(current-output-port)}.@refill
+@code{(current-output-port)}.
@end deffn
@defun pprint-filter-file infile proc outfile
@@ -3991,7 +4103,7 @@ are then @code{pretty-print}ed to this port.
Whitepsace and comments (introduced by @code{;}) which are not part of
scheme expressions are reproduced in the output. This procedure does
not affect the values returned by @code{current-input-port} and
-@code{current-output-port}.@refill
+@code{current-output-port}.
@end defun
@code{pprint-filter-file} can be used to pre-compile macro-expansion and
@@ -4116,7 +4228,7 @@ Creates and returns a time-zone object specified by the string
@var{tz} is a time-zone object. @code{tz:params} returns a list of
three items:
@enumerate 0
-@item
+@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}.
@@ -4389,110 +4501,7 @@ be mixed with regular text and ANSI or other terminal control sequences.
@node Schmooz, , Vector Graphics, Textual Conversion Packages
@section Schmooz
-@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.
-
+@include schmooz.texi
@node Mathematical Packages, Database Packages, Textual Conversion Packages, Top
@chapter Mathematical Packages
@@ -4506,6 +4515,7 @@ in schmooz comments.
* Cyclic Checksum:: 'make-crc
* Plotting:: 'charplot
* Root Finding:: 'root
+* Minimizing:: 'minimize
* Commutative Rings:: 'commutative-ring
* Determinant:: 'determinant
@end menu
@@ -4522,7 +4532,7 @@ The bit-twiddling functions are made available through the use of the
@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.@refill
+in two's-complement representation.
@subheading Bitwise Operations
@@ -4655,7 +4665,7 @@ Example:
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.@refill
+@var{start}th bit of the result.
Example:
@example
@@ -4668,7 +4678,7 @@ Example:
@defun ash int count
Returns an integer equivalent to
-@code{(inexact->exact (floor (* @var{int} (expt 2 @var{count}))))}.@refill
+@code{(inexact->exact (floor (* @var{int} (expt 2 @var{count}))))}.
Example:
@lisp
@@ -4713,7 +4723,7 @@ Example:
@defun extended-euclid n1 n2
Returns a list of 3 integers @code{(d x y)} such that d = gcd(@var{n1},
-@var{n2}) = @var{n1} * x + @var{n2} * y.@refill
+@var{n2}) = @var{n1} * x + @var{n2} * y.
@end defun
@defun symmetric:modulus n
@@ -4795,7 +4805,7 @@ Returns (@var{k2} ^ @var{k3}) mod @var{modulus}.
@ftindex factor
@ftindex primes
-@c @include factor.txi
+@include factor.txi
@node Random Numbers, Fast Fourier Transform, Prime Numbers, Mathematical Packages
@@ -4818,14 +4828,14 @@ from sequential bytes, tests fail. With the seed
@samp{http://swissnet.ai.mit.edu/~jaffer/SLIB.html}, all of those tests
pass.
-@c @include random.txi
+@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.
-@c @include randinex.txi
+@include randinex.txi
@node Fast Fourier Transform, Cyclic Checksum, Random Numbers, Mathematical Packages
@@ -4868,7 +4878,6 @@ Discrete Fourier Transform of @var{array}.
@defun make-port-crc
@defunx make-port-crc degree
-@defunx make-port-crc degree generator
Returns an expression for a procedure of one argument, a port. This
procedure reads characters from the port until the end of file and
returns the integer checksum of the bytes read.
@@ -4877,6 +4886,14 @@ 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
@@ -4907,7 +4924,7 @@ checksum from the polynomial:
(define (file-check-sum file) (call-with-input-file file crc32))
(file-check-sum (in-vicinity (library-vicinity) "ratize.scm"))
-@result{} 3553047446
+@result{} 157103930
@end example
@node Plotting, Root Finding, Cyclic Checksum, Mathematical Packages
@@ -4918,9 +4935,8 @@ checksum from the polynomial:
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
+@code{(require 'charplot)} before the code that uses this procedure.
@ftindex charplot
-procedure.@refill
@defvar charplot:height
The number of rows to make the plot vertically.
@@ -4933,7 +4949,7 @@ The number of columns to make the plot horizontally.
@deffn Procedure plot! coords x-label y-label
@var{coords} is a list of pairs of x and y coordinates. @var{x-label}
and @var{y-label} are strings with which to label the x and y
-axes.@refill
+axes.
Example:
@example
@@ -4955,29 +4971,36 @@ Example:
| |
1|- **** |
| ** ** |
- 750.0e-3|- * * |
+ 0.75|- * * |
| * * |
- 500.0e-3|- * * |
+ 0.5|- * * |
| * |
- 250.0e-3|- * |
+ 0.25|- * |
| * * |
0|-------------------*--------------------------|
| * |
- -250.0e-3|- * * |
+ -0.25|- * * |
| * * |
- -500.0e-3|- * |
+ -0.5|- * |
| * * |
- -750.0e-3|- * * |
+ -0.75|- * * |
| ** ** |
-1|- **** |
|____________:_____._____:_____._____:_________|
- x 2 4
+ 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, Commutative Rings, Plotting, Mathematical Packages
+@node Root Finding, Minimizing, Plotting, Mathematical Packages
@section Root Finding
@code{(require 'root)}
@@ -5065,7 +5088,7 @@ points @var{x0} and @var{x1}, returns a real @var{x} for which
If @var{x0} and @var{x1} are chosen such that they bracket a root, that is
@example
-(or (< (f x0) 0 (f x1))
+(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
@@ -5087,7 +5110,16 @@ iterations performed so far. @var{prec} should return non-false
if the iteration should be stopped.
@end defun
-@node Commutative Rings, Determinant, Root Finding, Mathematical Packages
+@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.
@@ -5106,6 +5138,7 @@ 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).
+@cindex self-set
@example
(define a 'a)
@@ -5114,16 +5147,17 @@ symbols).
@end example
Or just @code{(require 'self-set)}. Now try some sample expressions:
+@ftindex self-set
@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)
+(+ (+ 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
@@ -5134,16 +5168,16 @@ 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))
+(* (+ 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:
@@ -5394,12 +5428,16 @@ Now we are ready to compute!
@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
@@ -5576,14 +5614,14 @@ 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-key
+@cindex match-keys
@cindex match
@cindex wild-card
-In contrast, a @var{match-key} argument is a list of length equal to the
-number of primary keys. The @var{match-key} restricts the actions of
-the table command to those records whose primary keys all satisfy the
-corresponding element of the @var{match-key} list.
-The elements and their actions are:
+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
@@ -5598,27 +5636,31 @@ Any other value matches only those keys @code{equal?} to it.
@end table
@end quotation
-@defun for-each-key handle procedure match-key
+@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 satisfies @var{match-key} in an unspecified order.
+@var{handle} which satisfy @var{match-keys} in an unspecified order.
An unspecified value is returned.
@end defun
-@defun map-key handle procedure match-key
+@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 satisfies
-@var{match-key} in an unspecified order.
+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 match-key
+@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 satisfies @var{match-key} in the natural order for
+@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 match-key
-Removes all rows which satisfy @var{match-key} from the table opened in
+@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
@@ -5889,6 +5931,12 @@ 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}.
@@ -6531,7 +6579,7 @@ arguments from a @code{getopt} style argument list (@pxref{Getopt}).
((make-command-server rdb command-table)
command
(lambda (comname comval options positions
- arities types defaulters dirs aliases)
+ arities types defaulters dirs aliases)
(apply comval (getopt->arglist
argc argv options positions
arities types defaulters dirs aliases)))))
@@ -6546,38 +6594,38 @@ arguments from a @code{getopt} style argument list (@pxref{Getopt}).
(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) @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{}
+@print{}
Usage: cmd [OPTION ARGUMENT ...] ...
- -f, --flag
- -o, --optional[=]<number>
+ -f, --flag
+ -o, --optional[=]<number>
-n, --nary[=]<symbols> ...
-N, --nary1[=]<symbols> ...
- -s, --single[=]<string>
+ -s, --single[=]<string>
ERROR: getopt->parameter-list "unrecognized option" "-?"
@end example
@@ -6741,6 +6789,19 @@ database is then closed and reopened.
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
@@ -7376,6 +7437,7 @@ operation is equivalent to
@menu
* Data Structures:: Various data structures.
+* Sorting and Searching::
* Procedures:: Miscellaneous utility procedures.
* Standards Support:: Support for Scheme Standards.
* Session Support:: REPL and Debugging.
@@ -7383,7 +7445,7 @@ operation is equivalent to
@end menu
-@node Data Structures, Procedures, Other Packages, Other Packages
+@node Data Structures, Sorting and Searching, Other Packages, Other Packages
@section Data Structures
@@ -7393,6 +7455,7 @@ operation is equivalent to
* Array Mapping:: 'array-for-each
* Association Lists:: 'alist
* Byte:: 'byte
+* Portable Image Files:: 'pnm
* Collections:: 'collect
* Dynamic Data Type:: 'dynamic
* Hash Tables:: 'hash-table
@@ -7401,7 +7464,6 @@ operation is equivalent to
* Priority Queues:: 'priority-queue
* Queues:: 'queue
* Records:: 'record
-* Structures:: 'struct, 'structure
@end menu
@@ -7410,100 +7472,7 @@ operation is equivalent to
@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}.@refill
-@end defun
-
-When constructing an array, @var{bound} is either an inclusive range of
-indices expressed as a two element list, or an upper bound expressed as
-a single integer. So@refill
-@lisp
-(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2))
-@end lisp
-
-@defun make-shared-array array mapper bound1 bound2 @dots{}
-@code{make-shared-array} can be used to create shared subarrays of other
-arrays. The @var{mapper} is a function that translates coordinates in
-the new array into coordinates in the old array. A @var{mapper} must be
-linear, and its range must stay within the bounds of the old array, but
-it can be otherwise arbitrary. A simple example:@refill
-@lisp
-(define fred (make-array #f 8 8))
-(define freds-diagonal
- (make-shared-array fred (lambda (i) (list i i)) 8))
-(array-set! freds-diagonal 'foo 3)
-(array-ref fred 3 3)
- @result{} FOO
-(define freds-center
- (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j)))
- 2 2))
-(array-ref freds-center 0 0)
- @result{} FOO
-@end lisp
-@end defun
-
-@defun array-rank obj
-Returns the number of dimensions of @var{obj}. If @var{obj} is not an
-array, 0 is returned.
-@end defun
-
-@defun array-shape array
-@code{array-shape} returns a list of inclusive bounds. So:
-@lisp
-(array-shape (make-array 'foo 3 5))
- @result{} ((0 2) (0 4))
-@end lisp
-@end defun
-
-@defun array-dimensions array
-@code{array-dimensions} is similar to @code{array-shape} but replaces
-elements with a 0 minimum with one greater than the maximum. So:
-@lisp
-(array-dimensions (make-array 'foo 3 5))
- @result{} (3 5)
-@end lisp
-@end defun
-
-@deffn Procedure array-in-bounds? array index1 index2 @dots{}
-Returns @code{#t} if its arguments would be acceptable to
-@code{array-ref}.
-@end deffn
-
-@defun array-ref array index1 index2 @dots{}
-Returns the element at the @code{(@var{index1}, @var{index2})} element
-in @var{array}.@refill
-@end defun
-
-@deffn Procedure array-set! array new-value index1 index2 @dots{}
-@end deffn
-
-@defun array-1d-ref array index
-@defunx array-2d-ref array 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.@refill
-
-If you comment out the bounds checking code, this is about as efficient
-as you could ask for without help from the compiler.
-
-An exercise left to the reader: implement the rest of APL.
-
+@include array.txi
@node Array Mapping, Association Lists, Arrays, Data Structures
@@ -7570,7 +7539,7 @@ dimension. The order of copying is unspecified.
Alist functions provide utilities for treating a list of key-value pairs
as an associative database. These functions take an equality predicate,
@var{pred}, as an argument. This predicate should be repeatable,
-symmetric, and transitive.@refill
+symmetric, and transitive.
Alist functions can be used with a secondary index method such as hash
tables for improved performance.
@@ -7580,13 +7549,13 @@ Returns an @dfn{association function} (like @code{assq}, @code{assv}, or
@code{assoc}) corresponding to @var{pred}. The returned function
returns a key-value pair whose key is @code{pred}-equal to its first
argument or @code{#f} if no key in the alist is @var{pred}-equal to the
-first argument.@refill
+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}.@refill
+@var{key} does not appear in @var{alist}.
@end defun
@defun alist-associator pred
@@ -7625,7 +7594,7 @@ Applies @var{proc} to each pair of keys and values of @var{alist}.
unspecified.
@end defun
-@node Byte, Collections, Association Lists, Data Structures
+@node Byte, Portable Image Files, Association Lists, Data Structures
@subsection Byte
@code{(require 'byte)}
@@ -7680,7 +7649,7 @@ returned by @code{current-output-port}.
@end deffn
-@deffn Function read-byte
+@deffn Function read-byte
@deffnx Function read-byte port
Returns the next byte available from the input @var{port}, updating
@@ -7714,8 +7683,66 @@ inverses so far as @code{equal?} is concerned.
@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.
-@node Collections, Dynamic Data Type, Byte, Data Structures
+@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
@@ -7729,7 +7756,7 @@ Routines for managing collections. Collections are aggregate data
structures supporting iteration over their elements, similar to the
Dylan(TM) language, but with a different interface. They have
@dfn{elements} indexed by corresponding @dfn{keys}, although the keys
-may be implicit (as with lists).@refill
+may be implicit (as with lists).
New types of collections may be defined as YASOS objects (@pxref{Yasos}).
They must support the following operations:
@@ -7756,15 +7783,15 @@ collection's keys in order.
@end itemize
They might support specialized @code{for-each-key} and
-@code{for-each-elt} operations.@refill
+@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?}.@refill
+collections must answer @code{#t} to @code{collection?}.
@end defun
-@deffn Procedure map-elts proc . collections
-@deffnx Procedure do-elts proc . collections
+@deffn Procedure map-elts proc collection1 @dots{}
+@deffnx Procedure do-elts proc collection1 @dots{}
@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
@@ -7773,7 +7800,7 @@ supplied corresponds to te order in which the @var{collections} appear.
@code{do-elts} is used when only side-effects of @var{proc} are of
interest and its return value is unspecified. @code{map-elts} returns a
collection (actually a vector) of the results of the applications of
-@var{proc}.@refill
+@var{proc}.
Example:
@lisp
@@ -7782,11 +7809,11 @@ Example:
@end lisp
@end deffn
-@deffn Procedure map-keys proc . collections
-@deffnx Procedure do-keys proc . collections
+@deffn Procedure map-keys proc collection1 @dots{}
+@deffnx Procedure do-keys proc collection1 @dots{}
These are analogous to @code{map-elts} and @code{do-elts}, but each
iteration is over the @var{collections}' @emph{keys} rather than their
-elements.@refill
+elements.
Example:
@lisp
@@ -7801,13 +7828,13 @@ 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
+@defun reduce proc seed collection1 @dots{}
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}).@refill
+Functions}).
@ftindex common-list-functions
Examples:
@@ -7819,9 +7846,9 @@ Examples:
@end lisp
@end defun
-@defun any? pred . collections
+@defun any? pred collection1 @dots{}
A generalization of the list-based @code{some} (@pxref{Lists as
-sequences}) to collections.@refill
+sequences}) to collections.
Example:
@lisp
@@ -7830,9 +7857,9 @@ Example:
@end lisp
@end defun
-@defun every? pred . collections
+@defun every? pred collection1 @dots{}
A generalization of the list-based @code{every} (@pxref{Lists as
-sequences}) to collections.@refill
+sequences}) to collections.
Example:
@lisp
@@ -7854,11 +7881,11 @@ Returns the number of elements in @var{collection}.
@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.@refill
+list.
@end defun
Here is a sample collection: @code{simple-table} which is also a
-@code{table}.@refill
+@code{table}.
@lisp
(define-predicate TABLE?)
(define-operation (LOOKUP table key failure-object))
@@ -7937,7 +7964,7 @@ Create and returns a new @dfn{dynamic} whose global value is @var{obj}.
@defun dynamic? obj
Returns true if and only if @var{obj} is a dynamic. No object
satisfying @code{dynamic?} satisfies any of the other standard type
-predicates.@refill
+predicates.
@end defun
@defun dynamic-ref dyn
@@ -7947,7 +7974,7 @@ environment.
@deffn Procedure dynamic-set! dyn obj
Change the value of the given dynamic to @var{obj} in the current
-dynamic environment. The returned value is unspecified.@refill
+dynamic environment. The returned value is unspecified.
@end deffn
@defun call-with-dynamic-binding dyn obj thunk
@@ -7956,7 +7983,7 @@ environment in which the given dynamic has been bound to a new location
whose initial contents are the value @var{obj}. This dynamic
environment has precisely the same extent as the invocation of the thunk
and is thus captured by continuations created within that invocation and
-re-established by those continuations when they are invoked.@refill
+re-established by those continuations when they are invoked.
@end defun
The @code{dynamic-bind} macro is not implemented.
@@ -7975,7 +8002,7 @@ Returns a hash function (like @code{hashq}, @code{hashv}, or
@code{hash}) corresponding to the equality predicate @var{pred}.
@var{pred} should be @code{eq?}, @code{eqv?}, @code{equal?}, @code{=},
@code{char=?}, @code{char-ci=?}, @code{string=?}, or
-@code{string-ci=?}.@refill
+@code{string-ci=?}.
@end defun
A hash table is a vector of association lists.
@@ -7988,33 +8015,33 @@ Hash table functions provide utilities for an associative database.
These functions take an equality predicate, @var{pred}, as an argument.
@var{pred} should be @code{eq?}, @code{eqv?}, @code{equal?}, @code{=},
@code{char=?}, @code{char-ci=?}, @code{string=?}, or
-@code{string-ci=?}.@refill
+@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.@refill
+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}.@refill
+Returns a procedure of 2 arguments, @var{hashtab} and @var{key}, which
+returns the value associated with @var{key} in @var{hashtab} or
+@code{#f} if @var{key} does not appear in @var{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.@refill
+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.@refill
+removed.
@end defun
@defun hash-map proc hash-table
@@ -8048,21 +8075,21 @@ Hash tables use these functions.
Returns an exact non-negative integer less than @var{k}. For each
non-negative integer less than @var{k} there are arguments @var{obj} for
which the hashing functions applied to @var{obj} and @var{k} returns
-that integer.@refill
+that integer.
For @code{hashq}, @code{(eq? obj1 obj2)} implies @code{(= (hashq obj1 k)
-(hashq obj2))}.@refill
+(hashq obj2))}.
For @code{hashv}, @code{(eqv? obj1 obj2)} implies @code{(= (hashv obj1 k)
-(hashv obj2))}.@refill
+(hashv obj2))}.
For @code{hash}, @code{(equal? obj1 obj2)} implies @code{(= (hash obj1 k)
-(hash obj2))}.@refill
+(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}.@refill
+@code{hashq}.
@end defun
@@ -8134,7 +8161,7 @@ English pronunciation tend to map to the same key.
Soundex was a classic algorithm used for manual filing of personal
records before the advent of computers. It performs adequately for
-English names but has trouble with other nationalities.
+English names but has trouble with other languages.
See Knuth, Vol. 3 @cite{Sorting and searching}, pp 391--2
@@ -8187,18 +8214,18 @@ operations.
@end defun
@defun heap-length heap
-Returns the number of elements in @var{heap}.@refill
+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.@refill
+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.@refill
+@var{heap}, an error is signaled.
@end defun
The algorithm for priority queues was taken from @cite{Introduction to
@@ -8214,7 +8241,7 @@ Algorithms} by T. Cormen, C. Leiserson, R. Rivest. 1989 MIT Press.
A @dfn{queue} is a list where elements can be added to both the front
and rear, and removed from the front (i.e., they are what are often
-called @dfn{dequeues}). A queue may also be used like a stack.@refill
+called @dfn{dequeues}). A queue may also be used like a stack.
@defun make-queue
Returns a new, empty queue.
@@ -8237,7 +8264,7 @@ Adds @var{datum} to the rear of queue @var{q}.
@end deffn
All of the following functions raise an error if the queue @var{q} is
-empty.@refill
+empty.
@defun queue-front q
Returns the datum at the front of the queue @var{q}.
@@ -8251,14 +8278,14 @@ Returns the datum at the rear of the queue @var{q}.
@deffnx Procedure dequeue! q
Both of these procedures remove and return the datum at the front of the
queue. @code{queue-pop!} is used to suggest that the queue is being
-used like a stack.@refill
+used like a stack.
@end deffn
-@node Records, Structures, Queues, Data Structures
+@node Records, , Queues, Data Structures
@subsection Records
@code{(require 'record)}
@@ -8274,7 +8301,7 @@ string, but is only used for debugging purposes (such as the printed
representation of a record of the new type). The @var{field-names}
argument is a list of symbols naming the @dfn{fields} of a record of the
new type. It is an error if the list contains any duplicates. It is
-unspecified how record-type descriptors are represented.@refill
+unspecified how record-type descriptors are represented.
@end defun
@c @defun make-record-sub-type type-name field-names rtd
@@ -8283,11 +8310,11 @@ unspecified how record-type descriptors are represented.@refill
@c string. The @var{field-names} argument is a list of symbols naming the
@c additional @dfn{fields} to be appended to @var{field-names} of
@c @var{rtd}. It is an error if the combinded list contains any
-@c duplicates.@refill
+@c 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}.@refill
+@c the new record-sub-type will not neccessarily work for @var{rtd}.
@c @end defun
@defun record-constructor rtd [field-names]
@@ -8300,14 +8327,14 @@ fields not named in that list are unspecified. The @var{field-names}
argument defaults to the list of field names in the call to
@code{make-record-type} that created the type represented by @var{rtd};
if the @var{field-names} argument is provided, it is an error if it
-contains any duplicates or any symbols not in the default list.@refill
+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.@refill
+type; it returns a false value otherwise.
@end defun
@c @defun record-sub-predicate rtd
@@ -8315,7 +8342,7 @@ type; it returns a false value otherwise.@refill
@c @var{rtd} or its parents. The returned procedure accepts exactly one
@c argument and returns a true value if the argument is a member of the
@c indicated record type or its parents; it returns a false value
-@c otherwise.@refill
+@c otherwise.
@c @end defun
@defun record-accessor rtd field-name
@@ -8325,7 +8352,7 @@ accepts exactly one argument which must be a record of the appropriate
type; it returns the current value of the field named by the symbol
@var{field-name} in that record. The symbol @var{field-name} must be a
member of the list of field-names in the call to @code{make-record-type}
-that created the type represented by @var{rtd}.@refill
+that created the type represented by @var{rtd}.
@end defun
@@ -8338,7 +8365,7 @@ the symbol @var{field-name} in that record to contain the given value.
The returned value of the modifier procedure is unspecified. The symbol
@var{field-name} must be a member of the list of field-names in the call
to @code{make-record-type} that created the type represented by
-@var{rtd}.@refill
+@var{rtd}.
@end defun
In May of 1996, as a product of discussion on the @code{rrrs-authors}
@@ -8360,7 +8387,7 @@ Returns a true value if @var{obj} is a record of any type and a false
value otherwise. Note that @code{record?} may be true of any Scheme
value; of course, if it returns true for some particular value, then
@code{record-type-descriptor} is applicable to that value and returns an
-appropriate descriptor.@refill
+appropriate descriptor.
@end defun
@defun record-type-descriptor record
@@ -8370,88 +8397,28 @@ record. That is, for example, if the returned descriptor were passed to
value when passed the given record. Note that it is not necessarily the
case that the returned descriptor is the one that was passed to
@code{record-constructor} in the call that created the constructor
-procedure that created the given record.@refill
+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}.@refill
+@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}.@refill
+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.
+@node Sorting and Searching, Procedures, Data Structures, Other Packages
+@section Sorting and Searching
@menu
* Common List Functions:: 'common-list-functions
@@ -8459,15 +8426,13 @@ up here.
* 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
+* Sequence Comparison:: 'diff and longest-common-subsequence
@end menu
-@node Common List Functions, Tree Operations, Procedures, Procedures
+
+@node Common List Functions, Tree Operations, Sorting and Searching, Sorting and Searching
@subsection Common List Functions
@code{(require 'common-list-functions)}
@@ -8488,10 +8453,11 @@ optional arguments in some cases.
@node List construction, Lists as sets, Common List Functions, Common List Functions
@subsubsection List construction
-@defun make-list k . init
+@defun make-list k
+@defunx make-list k init
@code{make-list} creates and returns a list of @var{k} elements. If
@var{init} is included, all elements in the list are initialized to
-@var{init}.@refill
+@var{init}.
Example:
@lisp
@@ -8503,7 +8469,7 @@ Example:
@end defun
-@defun list* x . y
+@defun list* obj1 obj2 @dots{}
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
@@ -8524,7 +8490,7 @@ argument. Sometimes called @code{cons*}. E.g.:@refill
it. Only the top level of the list is copied, i.e., pairs forming
elements of the copied list remain @code{eq?} to the corresponding
elements of the original; the copy is, however, not @code{eq?} to the
-original, but is @code{equal?} to it.@refill
+original, but is @code{equal?} to it.
Example:
@lisp
@@ -8559,7 +8525,7 @@ 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})}.@refill
+@var{l}, otherwise, it returns @code{(cons @var{e} @var{l})}.
Example:
@lisp
@@ -8573,20 +8539,20 @@ Example:
@defun union l1 l2
@code{union} returns the combination of @var{l1} and @var{l2}.
Duplicates between @var{l1} and @var{l2} are culled. Duplicates within
-@var{l1} or within @var{l2} may or may not be removed.@refill
+@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)
+ @result{} (8 7 6 5 1 2 3 4)
(union '(1 2 3 4) '(3 4 5 6))
- @result{} (2 1 3 4 5 6)
+ @result{} (6 5 1 2 3 4)
@end lisp
@end defun
@defun intersection l1 l2
@code{intersection} returns all elements that are in both @var{l1} and
-@var{l2}.@refill
+@var{l2}.
Example:
@lisp
@@ -8598,8 +8564,8 @@ Example:
@end defun
@defun set-difference l1 l2
-@code{set-difference} returns the union of all elements that are in
-@var{l1} but not in @var{l2}.@refill
+@code{set-difference} returns all elements that are in @var{l1} but not
+in @var{l2}.
Example:
@lisp
@@ -8613,7 +8579,7 @@ Example:
@defun member-if pred lst
@code{member-if} returns @var{lst} if @code{(@var{pred} @var{element})}
is @code{#t} for any @var{element} in @var{lst}. Returns @code{#f} if
-@var{pred} does not apply to any @var{element} in @var{lst}.@refill
+@var{pred} does not apply to any @var{element} in @var{lst}.
Example:
@lisp
@@ -8624,13 +8590,13 @@ Example:
@end lisp
@end defun
-@defun some pred lst . more-lsts
+@defun some pred lst1 lst2 @dots{}
@var{pred} is a boolean function of as many arguments as there are list
arguments to @code{some} i.e., @var{lst} plus any optional arguments.
@var{pred} is applied to successive elements of the list arguments in
order. @code{some} returns @code{#t} as soon as one of these
applications returns @code{#t}, and is @code{#f} if none returns
-@code{#t}. All the lists should have the same length.@refill
+@code{#t}. All the lists should have the same length.
Example:
@@ -8646,10 +8612,10 @@ Example:
@end lisp
@end defun
-@defun every pred lst . more-lsts
+@defun every pred lst1 lst2 @dots{}
@code{every} is analogous to @code{some} except it returns @code{#t} if
every application of @var{pred} is @code{#t} and @code{#f}
-otherwise.@refill
+otherwise.
Example:
@lisp
@@ -8664,16 +8630,16 @@ Example:
@end lisp
@end defun
-@defun notany pred . lst
+@defun notany pred lst1 @dots{}
@code{notany} is analogous to @code{some} but returns @code{#t} if no
application of @var{pred} returns @code{#t} or @code{#f} as soon as any
-one does.@refill
+one does.
@end defun
-@defun notevery pred . lst
+@defun notevery pred lst1 @dots{}
@code{notevery} is analogous to @code{some} but returns @code{#t} as soon
as an application of @var{pred} returns @code{#f}, and @code{#f}
-otherwise.@refill
+otherwise.
Example:
@lisp
@@ -8685,11 +8651,33 @@ Example:
@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.@refill
+Otherwise, @code{#f} is returned.
Example:
@lisp
@@ -8708,7 +8696,7 @@ Example:
@code{remove} removes all occurrences of @var{elt} from @var{lst} using
@code{eqv?} to test for equality and returns everything that's left.
N.B.: other implementations (Chez, Scheme->C and T, at least) use
-@code{equal?} as the equality test.@refill
+@code{equal?} as the equality test.
Example:
@lisp
@@ -8723,7 +8711,7 @@ Example:
@defun remove-if pred lst
@code{remove-if} removes all @var{element}s from @var{lst} where
@code{(@var{pred} @var{element})} is @code{#t} and returns everything
-that's left.@refill
+that's left.
Example:
@lisp
@@ -8738,7 +8726,7 @@ Example:
@defun remove-if-not pred lst
@code{remove-if-not} removes all @var{element}s from @var{lst} for which
@code{(@var{pred} @var{element})} is @code{#f} and returns everything that's
-left.@refill
+left.
Example:
@lisp
@@ -8773,10 +8761,10 @@ Elements are considered duplicate if they are @code{equal?}.
Example:
@lisp
(remove-duplicates '(1 2 3 4))
- @result{} (4 3 2 1)
+ @result{} (1 2 3 4)
(remove-duplicates '(2 4 3 4))
- @result{} (3 4 2)
+ @result{} (2 4 3)
@end lisp
@end defun
@@ -8786,7 +8774,7 @@ Example:
@defun position obj lst
@code{position} returns the 0-based position of @var{obj} in @var{lst},
-or @code{#f} if @var{obj} does not occur in @var{lst}.@refill
+or @code{#f} if @var{obj} does not occur in @var{lst}.
Example:
@lisp
@@ -8806,7 +8794,7 @@ operation (the combination is left-associative). For example, using
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.@refill
+@code{collect} generalized to collections.
Example:
@lisp
@@ -8831,10 +8819,10 @@ Example:
What follows is a rather non-standard implementation of @code{reverse}
in terms of @code{reduce} and a combinator elsewhere called
-@dfn{C}.@refill
+@dfn{C}.
@lisp
-;;; Contributed by Jussi Piitulainen (jpiitula@@ling.helsinki.fi)
+;;; Contributed by Jussi Piitulainen (jpiitula @@ ling.helsinki.fi)
(define commute
(lambda (f)
@@ -8853,7 +8841,7 @@ inserts @var{init} at the start of the list. @code{reduce-init} is
preferred if you want to handle the null list, the one-element, and
lists with two or more elements consistently. It is common to use the
operator's idempotent as the initializer. Functional programmers
-usually call this @dfn{foldl}.@refill
+usually call this @dfn{foldl}.
Example:
@lisp
@@ -8919,7 +8907,7 @@ Example:
@defun butlast lst n
@code{butlast} returns all but the last @var{n} elements of
-@var{lst}.@refill
+@var{lst}.
Example:
@lisp
@@ -8956,14 +8944,14 @@ Example:
@defun butnthcdr n lst
@code{butnthcdr} returns all but the nthcdr @var{n} elements of
-@var{lst}.@refill
+@var{lst}.
Example:
@lisp
(butnthcdr 3 '(a b c d))
@result{} (a b c)
(butnthcdr 4 '(a b c d))
- @result{} ()
+ @result{} (a b c d)
@end lisp
@end defun
@@ -8988,7 +8976,7 @@ 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}).@refill
+Sometimes called @code{append!} (@pxref{Rev2 Procedures}).
Example: You want to find the subsets of a set. Here's the obvious way:
@@ -9002,7 +8990,7 @@ Example: You want to find the subsets of a set. Here's the obvious way:
@end lisp
But that does way more consing than you need. Instead, you could
replace the @code{append} with @code{nconc}, since you don't have any
-need for all the intermediate results.@refill
+need for all the intermediate results.
Example:
@lisp
@@ -9019,7 +9007,7 @@ x
@deffn Procedure nreverse lst
@code{nreverse} reverses the order of elements in @var{lst} by mutating
-@code{cdr}s of the list. Sometimes called @code{reverse!}.@refill
+@code{cdr}s of the list. Sometimes called @code{reverse!}.
Example:
@lisp
@@ -9048,7 +9036,7 @@ The example should suffice to show why this is the case.
@deffnx Procedure delete-if pred lst
@deffnx Procedure delete-if-not pred lst
Destructive versions of @code{remove} @code{remove-if}, and
-@code{remove-if-not}.@refill
+@code{remove-if-not}.
Example:
@lisp
@@ -9084,7 +9072,7 @@ The examples should suffice to show why this is the case.
@node Non-List functions, , Destructive list operations, Common List Functions
@subsubsection Non-List functions
-@defun and? . args
+@defun and? arg1 @dots{}
@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
@@ -9099,7 +9087,7 @@ Example:
@end lisp
@end defun
-@defun or? . args
+@defun or? arg1 @dots{}
@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
@@ -9126,18 +9114,8 @@ pair. (Called @code{atom} in Common LISP.)
@end lisp
@end defun
-@defun type-of object
-Returns a symbol name for the type of @var{object}.
-@end defun
-
-@defun coerce object result-type
-Converts and returns @var{object} of type @code{char}, @code{number},
-@code{string}, @code{symbol}, @code{list}, or @code{vector} to
-@var{result-type} (which must be one of these symbols).
-@end defun
-
-@node Tree Operations, Chapter Ordering, Common List Functions, Procedures
+@node Tree Operations, Chapter Ordering, Common List Functions, Sorting and Searching
@subsection Tree operations
@code{(require 'tree)}
@@ -9146,15 +9124,17 @@ Converts and returns @var{object} of type @code{char}, @code{number},
These are operations that treat lists a representations of trees.
@defun subst new old tree
+@defunx subst new old tree equ?
@defunx substq new old tree
@defunx substv new old tree
@code{subst} makes a copy of @var{tree}, substituting @var{new} for
every subtree or leaf of @var{tree} which is @code{equal?} to @var{old}
and returns a modified tree. The original @var{tree} is unchanged, but
-may share parts with the result.@refill
+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.@refill
+using @code{eq?} and @code{eqv?} respectively. If @code{subst} is
+called with a fourth argument, @var{equ?} is the equality predicate.
Examples:
@lisp
@@ -9171,7 +9151,7 @@ Examples:
@defun copy-tree tree
Makes a copy of the nested list structure @var{tree} using new pairs and
returns it. All levels are copied, so that none of the pairs in the
-tree are @code{eq?} to the original ones -- only the leaves are.@refill
+tree are @code{eq?} to the original ones -- only the leaves are.
Example:
@lisp
@@ -9184,7 +9164,7 @@ Example:
@end defun
-@node Chapter Ordering, Sorting, Tree Operations, Procedures
+@node Chapter Ordering, Sorting, Tree Operations, Sorting and Searching
@subsection Chapter Ordering
@code{(require 'chapter-order)}
@@ -9230,7 +9210,7 @@ chap:next-string will always be @code{chap:string<?} than the result.
@end defun
-@node Sorting, Topological Sort, Chapter Ordering, Procedures
+@node Sorting, Topological Sort, Chapter Ordering, Sorting and Searching
@subsection Sorting
@code{(require 'sort)}
@@ -9329,12 +9309,12 @@ The standard functions @code{<}, @code{>}, @code{char<?}, @code{char>?},
@code{char-ci<?}, @code{char-ci>?}, @code{string<?}, @code{string>?},
@code{string-ci<?}, and @code{string-ci>?} are suitable for use as
comparison functions. Think of @code{(less? x y)} as saying when
-@code{x} must @emph{not} precede @code{y}.@refill
+@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)}).@refill
+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.
@@ -9368,7 +9348,7 @@ Accepts either a list or a vector, and returns a new sequence which is
sorted. The new sequence is the same type as the input. Always
@code{(sorted? (sort sequence less?) less?)}. The original sequence is
not altered in any way. The new sequence shares its @emph{elements}
-with the old one; no elements are copied.@refill
+with the old one; no elements are copied.
@end defun
@deffn Procedure sort! sequence less?
@@ -9409,7 +9389,7 @@ in Common LISP, just write
@noindent
in Scheme.
-@node Topological Sort, String-Case, Sorting, Procedures
+@node Topological Sort, String Search, Sorting, Sorting and Searching
@subsection Topological Sort
@code{(require 'topological-sort)} or @code{(require 'tsort)}
@@ -9465,55 +9445,7 @@ tie or his belt.) `tsort' gives the correct order of dressing:
@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
-
-
-
-@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.@refill
-@end deffn
-
-@deffn Procedure call-with-input-string string proc
-@var{proc} must be a procedure of one argument. This procedure calls
-@var{proc} with one argument: an (newly created) input port from which
-@var{string}'s contents may be read. When @var{proc} returns, the port
-is closed and the value yielded by the procedure @var{proc} is
-returned.@refill
-@end deffn
-
-
-@node String Search, Line I/O, String Ports, Procedures
+@node String Search, Sequence Comparison, Topological Sort, Sorting and Searching
@subsection String Search
@code{(require 'string-search)}
@@ -9582,16 +9514,105 @@ Returns a copy of string @var{txt} with all occurrences of string
with @var{new2} @dots{}.
@end defun
-@node Line I/O, Multi-Processing, String Search, Procedures
+
+@node Sequence Comparison, , String Search, Sorting and Searching
+@subsection Sequence Comparison
+
+@code{(require 'diff)}
+@ftindex diff
+@cindex Sequence Comparison
+
+@include differ.txi
+
+
+@node Procedures, Standards Support, Sorting and Searching, Other Packages
+@section Procedures
+
+Anything that doesn't fall neatly into any of the other categories winds
+up here.
+
+@menu
+* Type Coercion:: 'coerce
+* String-Case:: 'string-case
+* String Ports:: 'string-port
+* Line I/O:: 'line-i/o
+* Multi-Processing:: 'process
+* Metric Units:: Portable manifest types for numeric values.
+@end menu
+
+
+@node Type Coercion, String-Case, Procedures, Procedures
+@subsection Type Coercion
+@code{(require 'coerce)}
+@ftindex coerce
+
+@include coerce.txi
+
+
+@node String-Case, String Ports, Type Coercion, 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, Line I/O, 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 Line I/O, Multi-Processing, String Ports, Procedures
@subsection Line I/O
@code{(require 'line-i/o)}
@ftindex line-i
-@c @include lineio.txi
+@include lineio.txi
-@node Multi-Processing, , Line I/O, Procedures
+@node Multi-Processing, Metric Units, Line I/O, Procedures
@subsection Multi-Processing
@code{(require 'process)}
@@ -9609,13 +9630,13 @@ of writing schedulers in Scheme.
Adds proc, which must be a procedure (or continuation) capable of
accepting accepting one argument, to the @code{process:queue}. The
value returned is unspecified. The argument to @var{proc} should be
-ignored. If @var{proc} returns, the process is killed.@refill
+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.@refill
+unspecified.
@end deffn
@deffn Procedure kill-process!
@@ -9625,6 +9646,214 @@ Kills the current process and runs the next process from
@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
@@ -9643,6 +9872,7 @@ Kills the current process and runs the next process from
* Dynamic-Wind:: 'dynamic-wind
* Eval:: 'eval
* Values:: 'values
+* SRFI:: 'http://srfi.schemers.org/srfi-0/srfi-0.html
@end menu
@node With-File, Transcripts, Standards Support, Standards Support
@@ -9665,7 +9895,7 @@ Description found in R4RS.
@defun transcript-on filename
@defunx transcript-off filename
Redefines @code{read-char}, @code{read}, @code{write-char},
-@code{write}, @code{display}, and @code{newline}.@refill
+@code{write}, @code{display}, and @code{newline}.
@end defun
@@ -9681,7 +9911,7 @@ Redefines @code{read-char}, @code{read}, @code{write-char},
The procedures below were specified in the @cite{Revised^2 Report on
Scheme}. @strong{N.B.}: The symbols @code{1+} and @code{-1+} are not
@cite{R4RS} syntax. Scheme->C, for instance, barfs on this
-module.@refill
+module.
@deffn Procedure substring-move-left! string1 start1 end1 string2 start2
@deffnx Procedure substring-move-right! string1 start1 end1 string2 start2
@@ -9696,23 +9926,23 @@ module.@refill
@code{substring-move-left!} and @code{substring-move-right!} store
characters of @var{string1} beginning with index @var{start1}
(inclusive) and ending with index @var{end1} (exclusive) into
-@var{string2} beginning with index @var{start2} (inclusive).@refill
+@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.@refill
+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}.@refill
+character @var{char}.
@end deffn
@defun string-null? str
@equiv{} @code{(= 0 (string-length @var{str}))}
@end defun
-@deffn Procedure append! . pairs
+@deffn Procedure append! pair1 @dots{}
Destructively appends its arguments. Equivalent to @code{nconc}.
@end deffn
@@ -9781,20 +10011,20 @@ For the specification of these optional procedures,
For the specification of these optional forms, @xref{Numerical
operations, , ,r4rs, Revised(4) Scheme}. The @code{two-arg:}* forms are
only defined if the implementation does not support the many-argument
-forms.@refill
+forms.
@defun two-arg:/ n1 n2
The original two-argument version of @code{/}.
@end defun
-@defun / divident . divisors
+@defun / dividend divisor1 @dots{}
@end defun
@defun two-arg:- n1 n2
The original two-argument version of @code{-}.
@end defun
-@defun - minuend . subtrahends
+@defun - minuend subtrahend1 @dots{}
@end defun
@@ -9816,7 +10046,7 @@ The implementation's native @code{apply}. Only defined for
implementations which don't support the many-argument version.
@end defun
-@defun apply proc . args
+@defun apply proc arg1 @dots{}
@end defun
@@ -9829,19 +10059,43 @@ implementations which don't support the many-argument version.
@code{(require 'rationalize)}
@ftindex rationalize
-The procedure rationalize is interesting because most programming
-languages do not provide anything analogous to it. For simplicity, we
-present an algorithm which computes the correct result for exact
-arguments (provided the implementation supports exact rational numbers
-of unlimited precision), and produces a reasonable answer for inexact
-arguments when inexact arithmetic is implemented using floating-point.
-We thank Alan Bawden for contributing this algorithm.
+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 e
+@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
@@ -9870,11 +10124,11 @@ doesn't support them
This facility is a generalization of Common LISP @code{unwind-protect},
designed to take into account the fact that continuations produced by
-@code{call-with-current-continuation} may be reentered.@refill
+@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).@refill
+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
@@ -9888,7 +10142,7 @@ context of @var{thunk2} if @var{thunk2} is on the current return stack).
@strong{Warning:} There is no provision for dealing with errors or
interrupts. If an error or interrupt occurs while using
@code{dynamic-wind}, the dynamic environment will be that in effect at
-the time of the error or interrupt.@refill
+the time of the error or interrupt.
@end deffn
@@ -9984,7 +10238,7 @@ car
@end example
-@node Values, , Eval, Standards Support
+@node Values, SRFI, Eval, Standards Support
@subsection Values
@code{(require 'values)}
@@ -9992,7 +10246,7 @@ car
@defun values obj @dots{}
@code{values} takes any number of arguments, and passes (returns) them
-to its continuation.@refill
+to its continuation.
@end defun
@@ -10000,15 +10254,29 @@ to its continuation.@refill
@var{thunk} must be a procedure of no arguments, and @var{proc} must be
a procedure. @code{call-with-values} calls @var{thunk} with a
continuation that, when passed some values, calls @var{proc} with those
-values as arguments.@refill
+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.@refill
+unspecified.
@end defun
+@node SRFI, , Values, Standards Support
+@subsection SRFI
+
+@include srfi.txi
+
+@menu
+* SRFI-1:: list-processing
+@end menu
+
+@node SRFI-1, , SRFI, SRFI
+@subsubsection SRFI-1
+
+@include srfi-1.txi
+
@node Session Support, Extra-SLIB Packages, Standards Support, Other Packages
@section Session Support
@@ -10036,7 +10304,7 @@ Here is a read-eval-print-loop which, given an eval, evaluates forms.
@code{(current-input-port)} to @code{(current-output-port)} until an
end-of-file is encountered. @code{load}, @code{slib:eval},
@code{slib:error}, and @code{repl:quit} dynamically bound during
-@code{repl:top-level}.@refill
+@code{repl:top-level}.
@end deffn
@deffn Procedure repl:quit
@@ -10051,7 +10319,7 @@ and interrupts. If your implementation supports this you are all set.
Otherwise, if there is some way your implementation can catch error
conditions and interrupts, then have them call @code{slib:error}. It
will display its arguments and reenter @code{repl:top-level}.
-@code{slib:error} dynamically bound by @code{repl:top-level}.@refill
+@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:
@@ -10090,12 +10358,12 @@ bit-vectors are @emph{not} limited.
substituting @samp{...} for substructure it does not have sufficient
room to print. @code{qpn} is like @code{qp} but outputs a newline
before returning. @code{qpr} is like @code{qpn} except that it returns
-its last argument.@refill
+its last argument.
@end deffn
@defvar *qp-width*
@code{*qp-width*} is the largest number of characters that @code{qp}
-should use.@refill
+should use.
@end defvar
@node Debug, Breakpoints, Quick Print, Session Support
@@ -10119,14 +10387,20 @@ printer for @code{qp}. This example shows how to do this:
@ftindex debug
@end example
-@deffn Procedure trace-all file
+@deffn Procedure trace-all file @dots{}
Traces (@pxref{Trace}) all procedures @code{define}d at top-level in
-file @file{file}.
+@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
+@deffn Procedure break-all file @dots{}
Breakpoints (@pxref{Breakpoints}) all procedures @code{define}d at
-top-level in file @file{file}.
+top-level in @file{file} @dots{}.
@end deffn
@node Breakpoints, Trace, Debug, Session Support
@@ -10176,15 +10450,11 @@ With no arguments, unbreaks all currently broken identifiers and returns
a list of these formerly broken identifiers.
@end defmac
-The following routines are the procedures which actually do the tracing
-when this module is supplied by SLIB, rather than natively. If
-defmacros are not natively supported by your implementation, these might
-be more convenient to use.
+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
-@defunx debug:breakf proc
-@defunx debug:breakf proc name
To break, type
@lisp
(set! @var{symbol} (breakf @var{symbol}))
@@ -10207,7 +10477,6 @@ or
@end defun
@defun unbreakf proc
-@defunx debug:unbreakf proc
To unbreak, type
@lisp
(set! @var{symbol} (unbreakf @var{symbol}))
@@ -10220,6 +10489,34 @@ To unbreak, type
@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
@@ -10228,22 +10525,48 @@ 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 off for its arguments.
+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
-The following routines are the procedures which actually do the tracing
-when this module is supplied by SLIB, rather than natively. If
-defmacros are not natively supported by your implementation, these might
-be more convenient to use.
+@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
-@defunx debug:tracef proc
-@defunx debug:tracef proc name
To trace, type
@lisp
(set! @var{symbol} (tracef @var{symbol}))
@@ -10266,7 +10589,7 @@ or
@end defun
@defun untracef proc
-@defunx debug:untracef proc
+Removes tracing, tracking, or stacking for @var{proc}.
To untrace, type
@lisp
(set! @var{symbol} (untracef @var{symbol}))
@@ -10301,7 +10624,7 @@ programs like FTP, mail, and Netscape.
@code{(require 'net-clients)}
@ftindex net-clients
-@c @include nclients.txi
+@include nclients.txi
@node Extra-SLIB Packages, , Session Support, Other Packages
@@ -10330,13 +10653,23 @@ and used as easily as any other SLIB package. Some optional packages
sites are:
@table @asis
-@item SLIB-PSD is a portable debugger for Scheme (requires emacs editor).
-@lisp
+@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
-ftp.gnu.org:pub/gnu/jacal/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
-@end lisp
+@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
@@ -10345,11 +10678,37 @@ 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
+Kellom\"aki, pk @@ cs.tut.fi. The Lisp Pointers article describing PSD
(Lisp Pointers VI(1):15-23, January-March 1993) is available as
-@url{http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html}
-@item SCHELOG is an embedding of Prolog in Scheme.
-@url{http://www.cs.rice.edu/CS/PLT/packages/schelog/}
+@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
@@ -10363,7 +10722,7 @@ you!
@quotation
SLIB @value{SLIBVERSION}, released @value{SLIBDATE}.@*
-Aubrey Jaffer <jaffer @@ ai.mit.edu>@*
+Aubrey Jaffer <agj @@ alum.mit.edu>@*
@i{Hyperactive Software} -- The Maniac Inside!@*
@url{http://swissnet.ai.mit.edu/~jaffer/SLIB.html}
@end quotation
@@ -10372,7 +10731,7 @@ Aubrey Jaffer <jaffer @@ ai.mit.edu>@*
@menu
* Installation:: How to install SLIB on your system.
* Porting:: SLIB to new platforms.
-* Coding Standards:: How to write modules for SLIB.
+* Coding Guidelines:: How to write modules for SLIB.
* Copyrights:: Intellectual propery issues.
@end menu
@@ -10388,9 +10747,33 @@ Aubrey Jaffer <jaffer @@ ai.mit.edu>@*
</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.
+There are four parts to installation:
+
+@itemize @bullet
+@item
+Unpack the SLIB distribution.
+@item
+Configure the Scheme implementation(s) to locate the SLIB directory.
+@item
+Arrange for Scheme implementation to load its SLIB initialization file.
+@item
+Build the SLIB catalog for the Scheme implementation.
+@end itemize
+
+@subsection Unpacking the SLIB Distribution
+
+If the SLIB distribution is a Linux RPM, it will create the SLIB
+directory @file{/usr/share/slib}.
+
+If the SLIB distribution is a ZIP file, unzip the distribution to create
+the SLIB directory. Locate this @file{slib} directory either in your
+home directory (if only you will use this SLIB installation); or put it
+in a location where libraries reside on your system. On unix systems
+this might be @file{/usr/share/slib}, @file{/usr/local/lib/slib}, or
+@file{/usr/lib/slib}. If you know where SLIB should go on other
+platforms, please inform agj @@ alum.mit.edu.
+
+@subsection Configure Scheme Implementation to Locate SLIB
If the Scheme implementation supports @code{getenv}, then the value of
the shell environment variable @var{SCHEME_LIBRARY_PATH} will be used
@@ -10399,6 +10782,15 @@ 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.)
+The @code{(library-vicinity)} can also be specified from the SLIB
+initialization file or by implementation-specific means.
+
+@subsection Loading SLIB Initialization File
+
+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.
+
You should check the definitions of @code{software-type},
@code{scheme-implementation-version},
@iftex
@@ -10408,27 +10800,105 @@ You should check the definitions of @code{software-type},
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.
+Once this is done, modify the startup file for your Scheme
+implementation to @code{load} this initialization file.
+
+@subsection Build New SLIB Catalog for Implementation
+
+When SLIB is first used from an implementation, a file named
+@file{slibcat} is written to the @code{implementation-vicinity} for that
+implementation. Because users may lack permission to write in
+@code{implementation-vicinity}, it is good practice to build the new
+catalog when installing SLIB.
+
+To build (or rebuild) the catalog, start the Scheme implementation (with
+SLIB), then:
+
+@example
+(require 'new-catalog)
+@end example
+
+@subsection Implementation-specific Instructions
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 in to SCM. See the documentation with SCM for
+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}
+
+The @file{init.ss} file in the _slibinit_ collection is an SLIB
+initialization file.
+
+To use SLIB in MzScheme, set the @var{SCHEME_LIBRARY_PATH} environment
+variable to the installed SLIB location; then invoke MzScheme thus:
+
+@code{mzscheme -L init.ss slibinit}
+@end deftp
+
+@deftp Implementation {MIT Scheme}
+@code{scheme -load $@{SCHEME_LIBRARY_PATH@}mitscheme.init}
+@end deftp
+
+@deftp Implementation {Guile}
+@code{guile -l $@{SCHEME_LIBRARY_PATH@}guile.init}
+@end deftp
+
-SLIB includes methods to create heap images for the VSCM and Scheme48
-implementations. The instructions for creating a VSCM image are in
-comments in @file{vscm.init}. To make a Scheme48 image for an
-installation under @code{<prefix>}, @code{cd} to the SLIB directory and
-type @code{make prefix=<prefix> slib48}. 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.
-@node Porting, Coding Standards, Installation, About SLIB
+@node Porting, Coding Guidelines, Installation, About SLIB
@section Porting
If there is no initialization file for your Scheme implementation, you
@@ -10453,31 +10923,31 @@ 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.@refill
+fashion.
-Please mail new working configuration files to @code{jaffer @@ ai.mit.edu}
-so that they can be included in the SLIB distribution.@refill
+Please mail new working configuration files to @code{agj @@ alum.mit.edu}
+so that they can be included in the SLIB distribution.
-@node Coding Standards, Copyrights, Porting, About SLIB
-@section Coding Standards
+@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}).@refill
+@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)}.@refill
+@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.@refill
+library packages.
Documentation should be provided in Emacs Texinfo format if possible,
But documentation must be provided.
@@ -10505,7 +10975,7 @@ 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 Standards, About SLIB
+@node Copyrights, , Coding Guidelines, About SLIB
@section Copyrights
@ifset html
@@ -10529,7 +10999,7 @@ need to add your copyright or send a disclaimer.
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.
+agj @@ alum.mit.edu for the address to mail the disclaimer to.
@quotation
I, @var{name}, hereby affirm that I have placed the software package
@@ -10554,7 +11024,7 @@ 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
+maintainer. Contact agj @@ alum.mit.edu for the address to mail the
disclaimer to. An example disclaimer follows.
@subheading Explicit copying terms
@@ -10574,7 +11044,7 @@ 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
+maintainer. Contact agj @@ alum.mit.edu for the address to mail the
disclaimer to.
@end itemize
diff --git a/srcdir.mk b/srcdir.mk
new file mode 100644
index 0000000..cdb825f
--- /dev/null
+++ b/srcdir.mk
@@ -0,0 +1,2 @@
+srcdir = /home/dres/project/debian/scheme/slib_2d2/
+
diff --git a/srfi-1.scm b/srfi-1.scm
new file mode 100644
index 0000000..1cebd9a
--- /dev/null
+++ b/srfi-1.scm
@@ -0,0 +1,253 @@
+;;; "srfi-1.scm" SRFI-1 list-processing library -*-scheme-*-
+; Copyright 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of 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 pieces from:
+;;;
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;; -Olin
+
+;;@code{(require 'srfi-1)}
+;;@ftindex srfi-1
+;;
+;;@noindent
+;;Implements the @dfn{SRFI-1} @dfn{list-processing library} as described
+;;at @url{http://srfi.schemers.org/srfi-1/srfi-1.html}
+
+(require 'common-list-functions)
+(require 'rev2-procedures) ;for append!
+(require 'values)
+
+;;@subheading Constructors
+
+;;@body @code{(define (xcons d a) (cons a d))}.
+(define (xcons d a) (cons a d))
+
+;;@body Returns a list of length @1. Element @var{i} is @code{(@2
+;;@var{i})} for 0 <= @var{i} < @1.
+(define (list-tabulate len proc)
+ (do ((i (- len 1) (- i 1))
+ (ans '() (cons (proc i) ans)))
+ ((< i 0) ans)))
+
+;;@args obj1 obj2
+(define cons* comlist:list*)
+
+;;@args count start step
+;;@args count start
+;;@args count
+;;Returns a list of @1 numbers: (@2, @2+@3, @dots{}, @2+(@1-1)*@3).
+(define (iota count . args)
+ (let ((start (if (null? args) 0 (car args)))
+ (step (if (or (null? args) (null? (cdr args))) 1 (cadr args))))
+ (list-tabulate count (lambda (idx) (+ start (* step idx))))))
+
+;;@body
+;;Returns a circular list of @1, @2, @dots{}.
+(define (circular-list obj1 . obj2)
+ (let ((ans (cons obj1 obj2)))
+ (set-cdr! (last-pair ans) ans)
+ ans))
+
+;;@subheading Predicates
+
+;;@args obj
+(define proper-list? list?)
+
+;;@body
+(define (circular-list? x)
+ (let lp ((x x) (lag x))
+ (and (pair? x)
+ (let ((x (cdr x)))
+ (and (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag)))
+ (or (eq? x lag) (lp x lag))))))))
+
+;;@body
+(define (dotted-list? obj)
+ (not (or (proper-list? obj) (circular-list? obj))))
+
+;;@args obj
+(define null-list? null?)
+
+;;@body
+(define (not-pair? obj) (not (pair? obj)))
+
+;;@body
+(define (list= =pred . lists)
+ (or (null? lists) ; special case
+ (let lp1 ((list-a (car lists)) (others (cdr lists)))
+ (or (null? others)
+ (let ((list-b (car others))
+ (others (cdr others)))
+ (if (eq? list-a list-b) ; EQ? => LIST=
+ (lp1 list-b others)
+ (let lp2 ((list-a list-a) (list-b list-b))
+ (if (null-list? list-a)
+ (and (null-list? list-b)
+ (lp1 list-b others))
+ (and (not (null-list? list-b))
+ (=pred (car list-a) (car list-b))
+ (lp2 (cdr list-a) (cdr list-b)))))))))))
+
+;;@subheading Selectors
+
+;;@args pair
+(define first car)
+(define second cadr)
+(define third caddr)
+(define fourth cadddr)
+(define (fifth obj) (car (cddddr obj)))
+(define (sixth obj) (cadr (cddddr obj)))
+(define (seventh obj) (caddr (cddddr obj)))
+(define (eighth obj) (cadddr (cddddr obj)))
+(define (ninth obj) (car (cddddr (cddddr obj))))
+(define (tenth obj) (cadr (cddddr (cddddr obj))))
+
+;;@body
+(define (car+cdr pair) (values (car pair) (cdr pair)))
+
+;;@body
+(define (take lst k) (comlist:butnthcdr k lst))
+(define take! take)
+(define (drop lst k) (comlist:nthcdr k lst))
+
+;;@args lst k
+(define take-right comlist:butlast)
+(define drop-right comlist:last)
+(define drop-right! drop-right)
+
+;;@body
+(define (split-at lst k) (values (take lst k) (drop lst k)))
+(define split-at! split-at)
+
+;;@args lst
+;;(car (last-pair lst))
+(define (last lst . k)
+ (if (null? k)
+ (car (last-pair lst))
+ (apply comlist:last lst k)))
+
+;;@subheading Miscellaneous
+
+;;@body
+(define (length+ obj) (and (list? obj) (length obj)))
+
+;;Append and append! are provided by R4RS and rev2-procedures.
+
+;;@body
+(define (concatenate lists) (reduce-right append '() lists))
+(define (concatenate! lists) (reduce-right append! '() lists))
+
+;;Reverse is provided by R4RS.
+;;@args lst
+(define reverse! comlist:nreverse)
+
+;;@body
+(define (append-reverse rev-head tail)
+ (let lp ((rev-head rev-head) (tail tail))
+ (if (null-list? rev-head) tail
+ (lp (cdr rev-head) (cons (car rev-head) tail)))))
+(define (append-reverse! rev-head tail)
+ (let lp ((rev-head rev-head) (tail tail))
+ (if (null-list? rev-head) tail
+ (let ((next-rev (cdr rev-head)))
+ (set-cdr! rev-head tail)
+ (lp next-rev rev-head)))))
+
+;;@body
+(define (zip list1 . list2) (apply map list list1 list2))
+
+;;@body
+(define (unzip1 lst) (map car lst))
+(define (unzip2 lst) (values (map car lst) (map cadr lst)))
+(define (unzip3 lst) (values (map car lst) (map cadr lst) (map caddr lst)))
+(define (unzip4 lst) (values (map car lst) (map cadr lst) (map caddr lst)
+ (map cadddr lst)))
+(define (unzip5 lst) (values (map car lst) (map cadr lst) (map caddr lst)
+ (map cadddr lst) (map fifth lst)))
+
+;;@body
+(define (count pred list1 . list2)
+ (cond ((null? list2)
+ (let mapf ((l list1) (count 0))
+ (if (null? l)
+ count (mapf (cdr l)
+ (+ count (if (pred (car l)) 1 0))))))
+ (else (let mapf ((l list1) (rest list2) (count 0))
+ (if (null? l)
+ count
+ (mapf (cdr l)
+ (map cdr rest)
+ (+ count (if (apply pred (car l) (map car rest))
+ 1 0))))))))
+
+;;@subheading Fold and Unfold
+
+;;@subheading Filtering and Partitioning
+
+;;@subheading Searching
+
+;;@args pred list
+(define find comlist:find-if)
+
+;;@args pred list
+(define find-tail comlist:member-if)
+
+
+;;@args obj list pred
+;;@args obj list
+;;
+;;@0 returns the first sublist of @2 whose car is @1, where the sublists
+;;of @2 are the non-empty lists returned by @t{(list-tail @2 @var{k})}
+;;for @var{k} less than the length of @2. If @1 does not occur in @2,
+;;then @t{#f} (not the empty list) is returned. The procedure @3 is
+;;used for testing equality. If @3 is not provided, @samp{equal?} is
+;;used.
+(define member
+ (let ((old-member member))
+ (lambda (obj list . pred)
+ (if (null? pred)
+ (old-member obj list)
+ (let ((pred (car pred)))
+ (find-tail (lambda (ob) (pred ob obj)) list))))))
+
+;;@subheading Deleting
+
+;;@subheading Association lists
+
+;;@args obj alist pred
+;;@args obj alist
+;;
+;;@2 (for ``association list'') must be a list of pairs. These
+;;procedures find the first pair in @2 whose car field is @1, and
+;;returns that pair. If no pair in @2 has @1 as its car, then @t{#f}
+;;(not the empty list) is returned. The procedure @3 is used for
+;;testing equality. If @3 is not provided, @samp{equal?} is used.
+(define assoc
+ (let ((old-assoc assoc))
+ (lambda (obj alist . pred)
+ (if (null? pred)
+ (old-assoc obj alist)
+ (let ((pred (car pred)))
+ (find (lambda (pair) (pred obj (car pair))) alist))))))
+
+;;@subheading Set operations
diff --git a/srfi-1.txi b/srfi-1.txi
new file mode 100644
index 0000000..a27fcc1
--- /dev/null
+++ b/srfi-1.txi
@@ -0,0 +1,178 @@
+@code{(require 'srfi-1)}
+@ftindex srfi-1
+
+@noindent
+Implements the @dfn{SRFI-1} @dfn{list-processing library} as described
+@cindex SRFI-1
+@cindex list-processing library
+at @url{http://srfi.schemers.org/srfi-1/srfi-1.html}
+
+@subheading Constructors
+
+
+@defun xcons d a
+@code{(define (xcons d a) (cons a d))}.
+@end defun
+
+@defun list-tabulate len proc
+Returns a list of length @var{len}. Element @var{i} is @code{(@var{proc}
+@var{i})} for 0 <= @var{i} < @var{len}.
+@end defun
+
+@defun cons* obj1 obj2
+
+@end defun
+
+@defun iota count start step
+
+
+@defunx iota count start
+
+@defunx iota count
+Returns a list of @var{count} numbers: (@var{start}, @var{start}+@var{step}, @dots{}, @var{start}+(@var{count}-1)*@var{step}).
+@end defun
+
+@defun circular-list obj1 obj2 @dots{}
+
+Returns a circular list of @var{obj1}, @var{obj2}, @dots{}.
+@end defun
+@subheading Predicates
+
+
+@defun proper-list? obj
+
+@end defun
+
+@defun circular-list? x
+
+@end defun
+
+@defun dotted-list? obj
+
+@end defun
+
+@defun null-list? obj
+
+@end defun
+
+@defun not-pair? obj
+
+@end defun
+
+@defun list= =pred list @dots{}
+
+@end defun
+@subheading Selectors
+
+
+@defun first pair
+@defunx fifth obj
+@defunx sixth obj
+@defunx seventh obj
+@defunx eighth obj
+@defunx ninth obj
+@defunx tenth obj
+
+@end defun
+
+@defun car+cdr pair
+
+@end defun
+
+@defun take lst k
+@defunx drop lst k
+
+@end defun
+
+@defun take-right lst k
+
+@end defun
+
+@defun split-at lst k
+
+@end defun
+
+@defun last lst
+
+(car (last-pair lst))
+@end defun
+@subheading Miscellaneous
+
+
+@defun length+ obj
+
+@end defun
+
+@defun concatenate lists
+@defunx concatenate! lists
+
+@end defun
+
+@defun reverse! lst
+
+@end defun
+
+@defun append-reverse rev-head tail
+@defunx append-reverse! rev-head tail
+
+@end defun
+
+@defun zip list1 list2 @dots{}
+
+@end defun
+
+@defun unzip1 lst
+@defunx unzip2 lst
+@defunx unzip3 lst
+@defunx unzip4 lst
+@defunx unzip5 lst
+
+@end defun
+
+@defun count pred list1 list2 @dots{}
+
+@end defun
+@subheading Fold and Unfold
+
+@subheading Filtering and Partitioning
+
+@subheading Searching
+
+
+@defun find pred list
+
+@end defun
+
+@defun find-tail pred list
+
+@end defun
+
+@defun member obj list pred
+
+
+@defunx member obj list
+
+@code{member} returns the first sublist of @var{list} whose car is @var{obj}, where the sublists
+of @var{list} are the non-empty lists returned by @t{(list-tail @var{list} @var{k})}
+for @var{k} less than the length of @var{list}. If @var{obj} does not occur in @var{list},
+then @t{#f} (not the empty list) is returned. The procedure @var{pred} is
+used for testing equality. If @var{pred} is not provided, @samp{equal?} is
+used.
+@end defun
+@subheading Deleting
+
+@subheading Association lists
+
+
+@defun assoc obj alist pred
+
+
+@defunx assoc obj alist
+
+@var{alist} (for ``association list'') must be a list of pairs. These
+procedures find the first pair in @var{alist} whose car field is @var{obj}, and
+returns that pair. If no pair in @var{alist} has @var{obj} as its car, then @t{#f}
+(not the empty list) is returned. The procedure @var{pred} is used for
+testing equality. If @var{pred} is not provided, @samp{equal?} is used.
+@end defun
+@subheading Set operations
diff --git a/srfi.scm b/srfi.scm
new file mode 100644
index 0000000..d491d28
--- /dev/null
+++ b/srfi.scm
@@ -0,0 +1,83 @@
+;;; "srfi.scm" Implement Scheme Request for Implementation -*-scheme-*-
+; Copyright 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;@code{(require 'srfi)}
+;;@ftindex srfi
+;;
+;;@noindent Implements @dfn{Scheme Request For Implementation} (SRFI) as
+;;described at @url{http://srfi.schemers.org/}
+;;
+;;@noindent The Copyright terms of each SRFI states:
+;;@quotation
+;;"However, this document itself may not be modified in any way, ..."
+;;@end quotation
+;;
+;;@noindent Therefore, the specification of SRFI constructs must not be
+;;quoted without including the complete SRFI document containing
+;;discussion and a sample implementation program.
+
+;;@args <clause1> <clause2> @dots{}
+;;
+;;@emph{Syntax:}
+;;Each @r{<clause>} should be of the form
+;;
+;;@format
+;;@t{(@r{<feature>} @r{<expression1>} @dots{})}
+;;@end format
+;;
+;;where @r{<feature>} is a boolean expression composed of symbols and
+;;`and', `or', and `not' of boolean expressions. The last @r{<clause>}
+;;may be an ``else clause,'' which has the form
+;;
+;;@format
+;;@t{(else @r{<expression1>} @r{<expression2>} @dots{})@r{.}}
+;;@end format
+;;
+;;The first clause whose feature expression is satisfied is expanded.
+;;If no feature expression is satisfied and there is no else clause, an
+;;error is signaled.
+;;
+;;SLIB @0 is an extension of SRFI-0,
+;;@url{http://srfi.schemers.org/srfi-0/srfi-0.html}.
+(defmacro cond-expand clauses
+ (letrec ((errout
+ (lambda (form exp)
+ (slib:error 'cond-expand 'invalid form ': exp)))
+ (feature?
+ (lambda (exp)
+ (cond ((symbol? exp)
+ (or (provided? exp) (eq? exp (software-type))))
+ ((and (pair? exp) (list? exp))
+ (case (car exp)
+ ((not) (not (feature? (cadr exp))))
+ ((or) (if (null? (cdr exp)) #f
+ (or (feature? (cadr exp))
+ (feature? (cons 'or (cddr exp))))))
+ ((and) (if (null? (cdr exp)) #t
+ (and (feature? (cadr exp))
+ (feature? (cons 'and (cddr exp))))))
+ (else (errout 'expression exp)))))))
+ (expand
+ (lambda (clauses)
+ (cond ((null? clauses) (slib:error 'Unfulfilled 'cond-expand))
+ ((not (pair? (car clauses))) (errout 'clause (car clauses)))
+ ((or (eq? 'else (caar clauses)) (feature? (caar clauses)))
+ `(begin ,@(cdar clauses)))
+ (else (expand (cdr clauses)))))))
+ (expand clauses)))
diff --git a/srfi.txi b/srfi.txi
new file mode 100644
index 0000000..52d2dbb
--- /dev/null
+++ b/srfi.txi
@@ -0,0 +1,42 @@
+@code{(require 'srfi)}
+@ftindex srfi
+
+@noindent Implements @dfn{Scheme Request For Implementation} (SRFI) as
+@cindex Scheme Request For Implementation
+described at @url{http://srfi.schemers.org/}
+
+@noindent The Copyright terms of each SRFI states:
+@quotation
+"However, this document itself may not be modified in any way, ..."
+@end quotation
+
+@noindent Therefore, the specification of SRFI constructs must not be
+quoted without including the complete SRFI document containing
+discussion and a sample implementation program.
+
+
+@defmac cond-expand <clause1> <clause2> @dots{}
+
+
+@emph{Syntax:}
+Each @r{<clause>} should be of the form
+
+@format
+@t{(@r{<feature>} @r{<expression1>} @dots{})}
+@end format
+
+where @r{<feature>} is a boolean expression composed of symbols and
+`and', `or', and `not' of boolean expressions. The last @r{<clause>}
+may be an ``else clause,'' which has the form
+
+@format
+@t{(else @r{<expression1>} @r{<expression2>} @dots{})@r{.}}
+@end format
+
+The first clause whose feature expression is satisfied is expanded.
+If no feature expression is satisfied and there is no else clause, an
+error is signaled.
+
+SLIB @code{cond-expand} is an extension of SRFI-0,
+@url{http://srfi.schemers.org/srfi-0/srfi-0.html}.
+@end defmac
diff --git a/strcase.scm b/strcase.scm
index b46b223..30b58ad 100644
--- a/strcase.scm
+++ b/strcase.scm
@@ -4,6 +4,7 @@
; 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
@@ -45,6 +46,21 @@
(string-capitalize! (string-copy str)))
(define string-ci->symbol
- (if (equal? "a" (symbol->string 'a))
- (lambda (str) (string->symbol (string-downcase str)))
- (lambda (str) (string->symbol (string-upcase str)))))
+ (let ((s2cis (if (equal? "x" (symbol->string 'x))
+ string-downcase string-upcase)))
+ (lambda (str) (string->symbol (s2cis str)))))
+
+(define symbol-append
+ (let ((s2cis (if (equal? "x" (symbol->string 'x))
+ string-downcase string-upcase)))
+ (lambda args
+ (string->symbol
+ (apply string-append
+ (map
+ (lambda (obj)
+ (cond ((string? obj) (s2cis obj))
+ ((number? obj) (s2cis (number->string obj)))
+ ((symbol? obj) (symbol->string obj))
+ ((not obj) "")
+ (else (slib:error 'wrong-type-to 'symbol-append obj))))
+ args))))))
diff --git a/strport.scm b/strport.scm
index a75ab0a..197d9a0 100644
--- a/strport.scm
+++ b/strport.scm
@@ -1,9 +1,9 @@
;;;;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/struct.scm b/struct.scm
deleted file mode 100644
index 100d3ff..0000000
--- a/struct.scm
+++ /dev/null
@@ -1,165 +0,0 @@
-;;; "struct.scm": defmacros for RECORDS
-;;; Copyright 1992 Jeff Alexander, Shinnder Lee, and Lewis Patterson
-
-;;; Defmacros which implement RECORDS from the book:
-;;; "Essentials of Programming Languages" by Daniel P. Friedman,
-;;; M. Wand and C.T. Haynes.
-
-;;; jaffer@ai.mit.edu, Feb 1993 ported to SLIB.
-
-;;; Date: Sun, 20 Aug 1995 19:20:35 -0500
-;;; From: Gary Leavens <leavens@cs.iastate.edu>
-;;; I thought you might want to know that, for using the file
-;;; struct.scm with the EOPL book, one has to make 2 corrections. To
-;;; correct it, there are two places where "-" has to be replaced by
-;;; "->" as in the code below.
-
-(require 'common-list-functions)
-
-(defmacro define-record args
- (check-define-record-syntax args
- (lambda (name make-name name? field-accessors field-setters)
- (letrec
- ((make-fields
- (lambda (field-accessors i)
- (if (null? field-accessors)
- '()
- (cons
- `(define ,(car field-accessors)
- (lambda (obj)
- (if (,name? obj)
- (vector-ref obj ,i)
- (slib:error ',(car field-accessors)
- ": bad record" obj))))
- (make-fields (cdr field-accessors) (+ i 1))))))
- (make-setters
- (lambda (field-accessors i)
- (if (null? field-accessors)
- '()
- (cons
- `(define ,(car field-accessors)
- (lambda (obj val)
- (if (,name? obj)
- (vector-set! obj ,i val)
- (slib:error ',(car field-accessors)
- ": bad record" obj))))
- (make-setters (cdr field-accessors) (+ i 1)))))))
- `(begin
- ,@(make-fields field-accessors 1)
- ,@(make-setters field-setters 1)
- (define ,name?
- (lambda (obj)
- (and (vector? obj)
- (= (vector-length obj) ,(+ 1 (length field-accessors)))
- (eq? (vector-ref obj 0) ',name))))
- (define ,make-name
- (lambda ,field-accessors
- (vector ',name ,@field-accessors))))))))
-
-(defmacro variant-case args
- (check-variant-case-syntax args
- (lambda (exp clauses)
- (let ((var (gentemp)))
- (let
- ((make-clause
- (lambda (clause)
- (if (eq? (car clause) 'else)
- `(#t ,@(cdr clause))
- `((,(car clause) ,var)
- (let ,(map (lambda (field)
- `(,(car field) (,(cdr field) ,var)))
- (cadr clause))
- ,@(cddr clause)))))))
- `(let ((,var ,exp))
- (cond ,@(map make-clause clauses))))))))
-
-;;; syntax checkers
-
-;;; name make-name name? field-accessors
-
-(define check-define-record-syntax
- (lambda (x k)
- (cond
- ((and (list? x)
- (= (length x) 2)
- (symbol? (car x))
- (list? (cadr x))
- (comlist:every symbol? (cadr x))
- (not (struct:duplicate-fields? (cadr x))))
- (let ((name (symbol->string (car x))))
- (let ((make-name (string->symbol
- (string-append (symbol->string 'make-) name)))
- (name? (string->symbol (string-append name "?")))
- (field-accessors
- (map
- (lambda (field)
- (string->symbol
- (string-append name "->" (symbol->string field))))
- (cadr x)))
- (field-setters
- (map
- (lambda (field)
- (string->symbol
- (string-append
- "set-" name "-" (symbol->string field) "!")))
- (cadr x))))
- (k (car x) make-name name? field-accessors field-setters))))
- (else (slib:error "define-record: invalid syntax" x)))))
-
-(define check-variant-case-syntax
- (let
- ((make-clause
- (lambda (clause)
- (if (eq? (car clause) 'else)
- clause
- (let ((name (symbol->string (car clause))))
- (let ((name? (string->symbol (string-append name "?")))
- (fields
- (map
- (lambda (field)
- (cons field
- (string->symbol
- (string-append name "->"
- (symbol->string field)))))
- (cadr clause))))
- (cons name? (cons fields (cddr clause)))))))))
- (lambda (args k)
- (if (and (list? args)
- (<= 2 (length args))
- (struct:clauses? (cdr args)))
- (k (car args) (map make-clause (cdr args)))
- (slib:error "variant-case: invalid syntax" args)))))
-
-(define struct:duplicate-fields?
- (lambda (fields)
- (cond
- ((null? fields) #f)
- ((memq (car fields) (cdr fields)) #t)
- (else (struct:duplicate-fields? (cdr fields))))))
-
-(define struct:clauses?
- (let
- ((clause?
- (lambda (clause)
- (and (list? clause)
- (not (null? clause))
- (cond
- ((eq? (car clause) 'else)
- (not (null? (cdr clause))))
- (else (and (symbol? (car clause))
- (not (null? (cdr clause)))
- (list? (cadr clause))
- (comlist:every symbol? (cadr clause))
- (not (struct:duplicate-fields? (cadr clause)))
- (not (null? (cddr clause))))))))))
- (letrec
- ((struct:duplicate-tags?
- (lambda (tags)
- (cond
- ((null? tags) #f)
- ((eq? (car tags) 'else) (not (null? (cdr tags))))
- ((memq (car tags) (cdr tags)) #t)
- (else (struct:duplicate-tags? (cdr tags)))))))
- (lambda (clauses)
- (and (comlist:every clause? clauses)
- (not (struct:duplicate-tags? (map car clauses))))))))
diff --git a/structst.scm b/structst.scm
deleted file mode 100644
index ea298e0..0000000
--- a/structst.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-;"structst.scm" test "struct.scm"
-;Copyright (C) 1993 Aubrey Jaffer
-;
-;Permission to copy this software, to redistribute it, and to use it
-;for any purpose is granted, subject to the following restrictions and
-;understandings.
-;
-;1. Any copy made of this software must include this copyright notice
-;in full.
-;
-;2. I have made no warrantee or representation that the operation of
-;this software will be error-free, and I am under no obligation to
-;provide any services, by way of maintenance, update, or otherwise.
-;
-;3. In conjunction with products arising from the use of this
-;material, there shall be no use of my name in any advertising,
-;promotional, or sales literature without prior written consent in
-;each case.
-
-(require 'struct)
-
-(define-record foo (a b c))
-(define-record goo (xx yy))
-
-(define a-foo (make-foo 1 2 3))
-(define a-goo (make-goo 4 5))
-
-(define (struct:test)
- (define (t1 x)
- (variant-case x
- (foo (a b c) (list a b c))
- (goo (xx yy) (list xx yy))
- (else (list 7 8))))
- (write (append (t1 a-foo) (t1 a-goo) (t1 9)))
- (newline))
-
-(struct:test)
diff --git a/syncase.sh b/syncase.sh
index 4ae4db4..4ae4db4 100644..100755
--- a/syncase.sh
+++ b/syncase.sh
diff --git a/synchk.scm b/synchk.scm
index 7e45a73..fadf14c 100644
--- a/synchk.scm
+++ b/synchk.scm
@@ -3,8 +3,9 @@
;;;
;;; 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
+;;; Engineering and Computer Science. Permission to copy and modify
+;;; this software, to redistribute either the original software or a
+;;; modified version, and to use this software for any purpose is
;;; granted, subject to the following restrictions and understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
diff --git a/synclo.scm b/synclo.scm
index 3c61de3..5883b93 100644
--- a/synclo.scm
+++ b/synclo.scm
@@ -3,8 +3,9 @@
;;;
;;; 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
+;;; Engineering and Computer Science. Permission to copy and modify
+;;; this software, to redistribute either the original software or a
+;;; modified version, and to use this software for any purpose is
;;; granted, subject to the following restrictions and understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
diff --git a/synrul.scm b/synrul.scm
index c23275f..4180aaf 100644
--- a/synrul.scm
+++ b/synrul.scm
@@ -3,8 +3,9 @@
;;;
;;; 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
+;;; Engineering and Computer Science. Permission to copy and modify
+;;; this software, to redistribute either the original software or a
+;;; modified version, and to use this software for any purpose is
;;; granted, subject to the following restrictions and understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
diff --git a/t3.init b/t3.init
index 4c0fb97..824d465 100644
--- a/t3.init
+++ b/t3.init
@@ -16,8 +16,8 @@
(define (scheme-implementation-version) "3.1")
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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)
@@ -59,24 +59,70 @@
;(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
+
+ ;; Scheme report features
+
+; rev5-report ;conforms to
+; eval ;R5RS two-argument eval
+; values ;R5RS multiple values
+; dynamic-wind ;R5RS dynamic-wind
+; macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
char-ready?
- with-file
- transcript
- full-continuation
+ rationalize
+ rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
+ ;LIST->STRING, STRING-COPY,
+ ;STRING-FILL!, LIST->VECTOR,
+ ;VECTOR->LIST, and VECTOR-FILL!
+
+; rev4-report ;conforms to
+
+; ieee-p1178 ;conforms to
+
+ rev3-report ;conforms to
+
+ rev2-procedures ;SUBSTRING-MOVE-LEFT!,
+ ;SUBSTRING-MOVE-RIGHT!,
+ ;SUBSTRING-FILL!,
+ ;STRING-NULL?, APPEND!, 1+,
+ ;-1+, <?, <=?, =?, >?, >=?
+ object-hash ;has OBJECT-HASH
+
+ multiarg/and- ;/ and - can take more than 2 args.
+ with-file ;has WITH-INPUT-FROM-FILE and
+ ;WITH-OUTPUT-FROM-FILE
+ transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
+; ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
+ full-continuation ;can return multiple times
+
+ ;; Other common features
+
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+; defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+; string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
+; sort
pretty-print
- format
+; object->string
+ format ;Common-lisp output formatting
trace ;has macros: TRACE and UNTRACE
- program-arguments
+; compiler ;has (COMPILER)
+; ed ;(ED) is editor
+; system ;posix (system <string>)
+; getenv ;posix (getenv <string>)
+ program-arguments ;returns list of strings (argv)
+; current-time ;returns time in seconds since 1/1/1970
+
+ ;; Implementation Specific features
+
+ i/o-redirection
))
(define substring
@@ -174,6 +220,13 @@
(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)
@@ -242,12 +295,15 @@
(define slib:warn
(lambda args
- (let ((port (current-error-port)))
- (display "Warn: " port)
- (for-each (lambda (x) (display x port)) 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 error)
+(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)
diff --git a/tek40.scm b/tek40.scm
index f45a1fa..b2be1ca 100644
--- a/tek40.scm
+++ b/tek40.scm
@@ -1,9 +1,9 @@
;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/tek41.scm b/tek41.scm
index 988f8ea..7d4c6b6 100644
--- a/tek41.scm
+++ b/tek41.scm
@@ -1,9 +1,9 @@
;"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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/timezone.scm b/timezone.scm
index a9149e3..d592478 100644
--- a/timezone.scm
+++ b/timezone.scm
@@ -1,9 +1,9 @@
;;;; "timezone.scm" Compute timezones and DST from TZ environment variable.
-;;; Copyright (C) 1994, 1996, 1997 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/trace.scm b/trace.scm
index 3476548..aa2c3d7 100644
--- a/trace.scm
+++ b/trace.scm
@@ -1,9 +1,9 @@
;;;; "trace.scm" Utility macros for tracing in Scheme.
-;;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Aubrey Jaffer.
+;;; 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -18,40 +18,112 @@
;each case.
(require 'qp) ;for the qp printer.
-(define debug:indent 0)
+(define trace:indent 0)
+(define debug:call-stack '()) ;keeps track of call stack.
+(define debug:max-count 5)
-(define debug:tracef
- (let ((null? null?) ;These bindings are so that
- (not not) ;tracef will not trace parts
- (car car) (cdr cdr) ;of itself.
+;;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)
+ (apply apply) (display display) (qpn qpn) (list list) (cons cons)
(CALL (string->symbol "CALL"))
(RETN (string->symbol "RETN")))
- (lambda (function . optname)
- (set! debug:indent 0)
+ (lambda (how 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:untrace-object)
- (null? (cdr args)))
- function)
- (else
- (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
- (apply qpn CALL name args)
- (set! debug:indent (modulo (+ 1 debug:indent) 16))
- (let ((ans (apply function args)))
- (set! debug:indent (modulo (+ -1 debug:indent) 16))
- (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
- (qpn RETN name ans)
- ans))))))))
-
-;;; the reason I use a symbol for debug:untrace-object is so
-;;; that functions can still be untraced if this file is read in twice.
-
-(define (debug:untracef function)
- (set! debug:indent 0)
+ (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
@@ -63,48 +135,120 @@
(define trace:deler (alist-remover eq?))
(define *traced-procedures* '())
-(define (trace:tracef fun sym)
+(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 " (current-error-port))
- (display sym (current-error-port))
- (newline (current-error-port))
+ (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 *traced-procedures*)))
+ (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:tracef fun sym)))
- (set! *traced-procedures*
- (trace:adder *traced-procedures* sym tfun))
+ (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:untracef fun sym)
- (let ((p (assq sym *traced-procedures*)))
- (set! *traced-procedures* (trace:deler *traced-procedures* sym))
- (cond ((not (procedure? fun)) fun)
- ((not p) fun)
- ((eq? (cdr p) fun)
- (debug:untracef fun))
- (else fun))))
+(define (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 debug:tracef)
-(define untracef debug:untracef)
+(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! debug:indent 0)
- ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x)))
+ `(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:tracef ,x ',x))) xs))))
+ `(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:untracef ,x ',x)))
+ `(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:untracef ,x ',x))) xs))))
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (trace:untrace-procedure ,x ',x))) xs))))
+
+(defmacro untrack xs
+ (if (null? xs)
+ (slib:eval
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (track:untrack-procedure ,x ',x)))
+ (map car *tracked-procedures*))
+ '',(map car *tracked-procedures*)))
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (track:untrack-procedure ,x ',x))) xs))))
+
+(defmacro unstack xs
+ (if (null? xs)
+ (slib:eval
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (stack:unstack-procedure ,x ',x)))
+ (map car *stacked-procedures*))
+ '',(map car *stacked-procedures*)))
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (stack:unstack-procedure ,x ',x))) xs))))
diff --git a/tree.scm b/tree.scm
index f400d1b..e9bc999 100644
--- a/tree.scm
+++ b/tree.scm
@@ -1,21 +1,7 @@
;;"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.
+;;; Author: Aubrey Jaffer
+;;;
+;;; This code is in the public domain.
;; Deep copy of the tree -- new one has all new pairs. (Called
;; tree-copy in Dybvig.)
@@ -27,34 +13,23 @@
;; 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))))
+(define (tree:subst new old tree . equ?)
+ (set! equ? (if (null? equ?) equal? (car equ?)))
+ (letrec ((walk (lambda (tree)
+ (cond ((equ? old tree) new)
+ ((pair? tree)
+ (cons (walk (car tree))
+ (walk (cdr tree))))
+ (else tree)))))
+ (walk 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))))
+ (tree:subst new old tree eq?))
(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))))
+ (tree:subst new old tree eqv?))
(define copy-tree tree:copy-tree)
(define subst tree:subst)
diff --git a/trnscrpt.scm b/trnscrpt.scm
index 45d884e..3f2c8a1 100644
--- a/trnscrpt.scm
+++ b/trnscrpt.scm
@@ -1,9 +1,9 @@
; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/tzfile.scm b/tzfile.scm
index ca53829..51c85e8 100644
--- a/tzfile.scm
+++ b/tzfile.scm
@@ -1,9 +1,9 @@
; "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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/umbscheme.init b/umbscheme.init
index 4532735..87c1638 100644
--- a/umbscheme.init
+++ b/umbscheme.init
@@ -17,8 +17,8 @@
(define (scheme-implementation-type) 'umb-scheme)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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)
@@ -74,6 +74,7 @@
; rev4-report ;conforms to
; rev3-report ;conforms to
ieee-p1178 ;conforms to
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
; sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
@@ -107,7 +108,6 @@
; object-hash ;has OBJECT-HASH
; sort
-; queue ;queues
; pretty-print
; object->string
; format
@@ -117,10 +117,6 @@
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
))
@@ -159,7 +155,7 @@
(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.
@@ -168,6 +164,13 @@
;;; 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)
@@ -209,12 +212,15 @@
(define slib:warn
(lambda args
- (let ((port (current-error-port)))
- (display "Warn: " port)
- (for-each (lambda (x) (display x port)) 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 error)
+(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))
diff --git a/uri.scm b/uri.scm
new file mode 100644
index 0000000..0fe685f
--- /dev/null
+++ b/uri.scm
@@ -0,0 +1,319 @@
+;;; "uri.scm" Construct and decode Uniform Resource Identifiers. -*-scheme-*-
+; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of 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)}
+;;@ftindex uri
+;;
+;;@noindent Implements @dfn{Uniform Resource Identifiers} (URI) as
+;;described in RFC 2396.
+
+;;@args
+;;@args fragment
+;;@args query fragment
+;;@args path query fragment
+;;@args authority path query fragment
+;;@args scheme authority path query fragment
+;;
+;;Returns a Uniform Resource Identifier string from component arguments.
+(define (make-uri . args)
+ (define nargs (length args))
+ (set! args (reverse args))
+ (let ((fragment (if (>= nargs 1) (car args) #f))
+ (query (if (>= nargs 2) (cadr args) #f))
+ (path (if (>= nargs 3) (caddr args) #f))
+ (authority (if (>= nargs 4) (cadddr args) #f))
+ (scheme (if (>= nargs 5) (list-ref args 4) #f)))
+ (string-append
+ (if scheme (sprintf #f "%s:" scheme) "")
+ (cond ((string? authority)
+ (sprintf #f "//%s" (uric:encode authority "$,;:@&=+")))
+ ((list? authority)
+ (apply (lambda (userinfo host port)
+ (cond ((and userinfo port)
+ (sprintf #f "//%s@%s:%d"
+ (uric:encode userinfo "$,;:&=+")
+ host port))
+ (userinfo
+ (sprintf #f "//%s@%s"
+ (uric:encode userinfo "$,;:&=+")
+ host))
+ (port
+ (sprintf #f "//%s:%d" host port))
+ (else host)))
+ authority))
+ (else (or authority "")))
+ (cond ((string? path) (uric:encode path "/$,;:@&=+"))
+ ((null? path) "")
+ ((list? path) (uri:make-path path))
+ (else path))
+ (if query (sprintf #f "?%s" (uric:encode query "?/$,;:@&=+")) "")
+ (if fragment (sprintf #f "#%s" (uric:encode fragment "?/$,;:@&=+")) ""))))
+
+(define (uri:make-path path)
+ (apply string-append
+ (uric:encode (car path) "$,;:@&=+")
+ (map (lambda (pth) (string-append "/" (uric:encode pth "$,;:@&=+")))
+ (cdr path))))
+
+;;@body Returns a string which defines this location in the (HTML) file
+;;as @1. The hypertext @samp{<A HREF="#@1">} will link to this point.
+;;
+;;@example
+;;(html:anchor "(section 7)")
+;;@result{}
+;;"<A NAME=\"(section%207)\"></A>"
+;;@end example
+(define (html:anchor name)
+ (sprintf #f "<A NAME=\"%s\"></A>" (uric:encode name "#?/:@;=")))
+
+;;@body Returns a string which links the @2 text to @1.
+;;
+;;@example
+;;(html:link (make-uri "(section 7)") "section 7")
+;;@result{}
+;;"<A HREF=\"#(section%207)\">section 7</A>"
+;;@end example
+(define (html:link uri highlighted)
+ (sprintf #f "<A HREF=\"%s\">%s</A>" uri highlighted))
+
+;;@body Returns a string specifying the @dfn{base} @1 of a document, for
+;;inclusion in the HEAD of the document (@pxref{HTML, head}).
+(define (html:base uri)
+ (sprintf #f "<BASE HREF=\"%s\">" uri))
+
+;;@body Returns a string specifying the search @1 of a document, for
+;;inclusion in the HEAD of the document (@pxref{HTML, head}).
+(define (html:isindex prompt)
+ (sprintf #f "<ISINDEX PROMPT=\"%s\">" prompt))
+
+;;@body Returns a list of 5 elements corresponding to the parts
+;;(@var{scheme} @var{authority} @var{path} @var{query} @var{fragment})
+;;of string @1. Elements corresponding to absent parts are #f.
+;;
+;;The @var{path} is a list of strings. If the first string is empty,
+;;then the path is absolute; otherwise relative.
+;;
+;;If the @var{authority} component is a
+;;@dfn{Server-based Naming Authority}, then it is a list of the
+;;@var{userinfo}, @var{host}, and @var{port} strings (or #f). For other
+;;types of @var{authority} components the @var{authority} will be a
+;;string.
+;;
+;;@example
+;;(uri->tree "http://www.ics.uci.edu/pub/ietf/uri/#Related")
+;;@result{}
+;;(http "www.ics.uci.edu" ("" "pub" "ietf" "uri" "") #f "Related")
+;;@end example
+(define (uri->tree uri-reference . base-tree)
+ (define split (uri:split uri-reference))
+ (apply (lambda (b-scheme b-authority b-path b-query b-fragment)
+ (apply
+ (lambda (scheme authority path query fragment)
+ (define uri-empty?
+ (and (equal? "" path) (not scheme) (not authority) (not query)))
+ (list (if scheme
+ (string-ci->symbol scheme)
+ b-scheme)
+ (if authority
+ (uri:decode-authority authority)
+ b-authority)
+ (if uri-empty?
+ (or b-path '(""))
+ (uri:decode-path
+ (map uric:decode (uri:split-fields path #\/))
+ (and (not authority) (not scheme) b-path)))
+ (if uri-empty?
+ b-query
+ query)
+ (or (and fragment (uric:decode fragment))
+ (and uri-empty? b-fragment))))
+ split))
+ (if (or (car split) (null? base-tree) (car split))
+ '(#f #f #f #f #f)
+ (car base-tree))))
+
+(define (uri:decode-path path-list base-path)
+ (cond ((and (equal? "" (car path-list))
+ (not (equal? '("") path-list)))
+ path-list)
+ (base-path
+ (let* ((cpath0 (append (butlast base-path 1) path-list))
+ (cpath1
+ (let remove ((l cpath0) (result '()))
+ (cond ((null? l) (reverse result))
+ ((not (equal? "." (car l)))
+ (remove (cdr l) (cons (car l) result)))
+ ((null? (cdr l))
+ (reverse (cons "" result)))
+ (else (remove (cdr l) result)))))
+ (cpath2
+ (let remove ((l cpath1) (result '()))
+ (cond ((null? l) (reverse result))
+ ((not (equal? ".." (car l)))
+ (remove (cdr l) (cons (car l) result)))
+ ((or (null? result)
+ (equal? "" (car result)))
+ (slib:warn 'uri:decode-path cpath1)
+ (append (reverse result) l))
+ ((null? (cdr l))
+ (reverse (cons "" (cdr result))))
+ (else (remove (cdr l) (cdr result)))))))
+ cpath2))
+ (else path-list)))
+
+(define (uri:decode-authority authority)
+ (define idx-at (string-index authority #\@))
+ (let* ((userinfo (and idx-at (uric:decode (substring authority 0 idx-at))))
+ (hostport
+ (if idx-at
+ (substring authority (+ 1 idx-at) (string-length authority))
+ authority))
+ (idx-: (string-index hostport #\:))
+ (host (if idx-: (substring hostport 0 idx-:) hostport))
+ (port (and idx-:
+ (substring hostport (+ 1 idx-:) (string-length hostport)))))
+ (if (or userinfo port)
+ (list userinfo host (or (string->number port) port))
+ host)))
+
+(define uri:split-fields
+ (let ((cr (integer->char #xd)))
+ (lambda (txt chr)
+ (define idx (string-index txt chr))
+ (if idx
+ (cons (substring txt 0
+ (if (and (positive? idx)
+ (char=? cr (string-ref txt (+ -1 idx))))
+ (+ -1 idx)
+ idx))
+ (uri:split-fields (substring txt (+ 1 idx) (string-length txt))
+ chr))
+ (list txt)))))
+
+;; @body Converts a @dfn{URI} encoded @1 to a query-alist.
+(define (uri:decode-query query-string)
+ (set! query-string (string-subst query-string " " "" "+" " "))
+ (do ((lst '())
+ (edx (string-index query-string #\=)
+ (string-index query-string #\=)))
+ ((not edx) lst)
+ (let* ((rxt (substring query-string (+ 1 edx) (string-length query-string)))
+ (adx (string-index rxt #\&))
+ (urid (uric:decode
+ (substring rxt 0 (or adx (string-length rxt)))))
+ (name (string-ci->symbol
+ (uric:decode (substring query-string 0 edx)))))
+ (set! lst (append lst (if (equal? "" urid)
+ '()
+ (map (lambda (value) (list name value))
+ (uri:split-fields urid #\newline)))))
+ (set! query-string
+ (if adx (substring rxt (+ 1 adx) (string-length rxt)) "")))))
+
+(define (uri:split uri-reference)
+ (define len (string-length uri-reference))
+ (define idx-sharp (string-index uri-reference #\#))
+ (let ((fragment (and idx-sharp
+ (substring uri-reference (+ 1 idx-sharp) len)))
+ (uri (if idx-sharp
+ (and (not (zero? idx-sharp))
+ (substring uri-reference 0 idx-sharp))
+ uri-reference)))
+ (if uri
+ (let* ((len (string-length uri))
+ (idx-? (string-index uri #\?))
+ (query (and idx-? (substring uri (+ 1 idx-?) len)))
+ (front (if idx-?
+ (and (not (zero? idx-?)) (substring uri 0 idx-?))
+ uri)))
+ (if front
+ (let* ((len (string-length front))
+ (idx-: (string-index front #\:))
+ (scheme (and idx-: (substring front 0 idx-:)))
+ (path (if idx-:
+ (substring front (+ 1 idx-:) len)
+ front)))
+ (cond ((eqv? 0 (substring? "//" path))
+ (set! len (string-length path))
+ (set! path (substring path 2 len))
+ (set! len (+ -2 len))
+ (let* ((idx-/ (string-index path #\/))
+ (authority (substring path 0 (or idx-/ len)))
+ (path (if idx-/
+ (substring path idx-/ len)
+ "")))
+ (list scheme authority path query fragment)))
+ (else (list scheme #f path query fragment))))
+ (list #f #f "" query fragment)))
+ (list #f #f "" #f fragment))))
+
+;;@
+;;@noindent @code{uric:} prefixes indicate procedures dealing with
+;;URI-components.
+
+;;@body Returns a copy of the string @1 in which all @dfn{unsafe} octets
+;;(as defined in RFC 2396) have been @samp{%} @dfn{escaped}.
+;;@code{uric:decode} decodes strings encoded by @0.
+(define (uric:encode uri-component allows)
+ (set! uri-component (sprintf #f "%a" uri-component))
+ (apply string-append
+ (map (lambda (chr)
+ (if (or (char-alphabetic? chr)
+ (char-numeric? chr)
+ (string-index "-_.!~*'()" chr)
+ (string-index allows chr))
+ (string chr)
+ (let ((code (char->integer chr)))
+ (sprintf #f "%%%02x" code))))
+ (string->list uri-component))))
+
+;;@body Returns a copy of the string @1 in which each @samp{%} escaped
+;;characters in @1 is replaced with the character it encodes. This
+;;routine is useful for showing URI contents on error pages.
+(define (uric:decode uri-component)
+ (define len (string-length uri-component))
+ (define (sub uri)
+ (cond
+ ((string-index uri #\%)
+ => (lambda (idx)
+ (if (and (< (+ 2 idx) len)
+ (string->number (substring uri (+ 1 idx) (+ 2 idx)) 16)
+ (string->number (substring uri (+ 2 idx) (+ 3 idx)) 16))
+ (string-append
+ (substring uri 0 idx)
+ (string (integer->char
+ (string->number
+ (substring uri (+ 1 idx) (+ 3 idx))
+ 16)))
+ (sub (substring uri (+ 3 idx) (string-length uri)))))))
+ (else uri)))
+ (sub uri-component))
+
+(define (uri:path->keys path-list ptypes)
+ (and (not (null? path-list))
+ (not (equal? '("") path-list))
+ (let ((path (uri:decode-path (map uric:decode path-list) #f)))
+ (and (= (length path) (length ptypes))
+ (map coerce path ptypes)))))
diff --git a/uri.txi b/uri.txi
new file mode 100644
index 0000000..096ff83
--- /dev/null
+++ b/uri.txi
@@ -0,0 +1,95 @@
+@code{(require 'uri)}
+@ftindex uri
+
+@noindent Implements @dfn{Uniform Resource Identifiers} (URI) as
+@cindex Uniform Resource Identifiers
+described in RFC 2396.
+
+
+@defun make-uri
+
+
+@defunx make-uri fragment
+
+@defunx make-uri query fragment
+
+@defunx make-uri path query fragment
+
+@defunx make-uri authority path query fragment
+
+@defunx make-uri scheme authority path query fragment
+
+Returns a Uniform Resource Identifier string from component arguments.
+@end defun
+
+@defun html:anchor name
+Returns a string which defines this location in the (HTML) file
+as @var{name}. The hypertext @samp{<A HREF="#@var{name}">} will link to this point.
+
+@example
+(html:anchor "(section 7)")
+@result{}
+"<A NAME=\"(section%207)\"></A>"
+@end example
+@end defun
+
+@defun html:link uri highlighted
+Returns a string which links the @var{highlighted} text to @var{uri}.
+
+@example
+(html:link (make-uri "(section 7)") "section 7")
+@result{}
+"<A HREF=\"#(section%207)\">section 7</A>"
+@end example
+@end defun
+
+@defun html:base uri
+Returns a string specifying the @dfn{base} @var{uri} of a document, for
+@cindex base
+inclusion in the HEAD of the document (@pxref{HTML, head}).
+@end defun
+
+@defun html:isindex prompt
+Returns a string specifying the search @var{prompt} of a document, for
+inclusion in the HEAD of the document (@pxref{HTML, head}).
+@end defun
+
+@defun uri->tree uri-reference base-tree @dots{}
+Returns a list of 5 elements corresponding to the parts
+(@var{scheme} @var{authority} @var{path} @var{query} @var{fragment})
+of string @var{uri-reference}. Elements corresponding to absent parts are #f.
+
+The @var{path} is a list of strings. If the first string is empty,
+then the path is absolute; otherwise relative.
+
+If the @var{authority} component is a
+@dfn{Server-based Naming Authority}, then it is a list of the
+@cindex Server-based Naming Authority
+@var{userinfo}, @var{host}, and @var{port} strings (or #f). For other
+types of @var{authority} components the @var{authority} will be a
+string.
+
+@example
+(uri->tree "http://www.ics.uci.edu/pub/ietf/uri/#Related")
+@result{}
+(http "www.ics.uci.edu" ("" "pub" "ietf" "uri" "") #f "Related")
+@end example
+@end defun
+
+@noindent @code{uric:} prefixes indicate procedures dealing with
+URI-components.
+
+
+@defun uric:encode uri-component allows
+Returns a copy of the string @var{uri-component} in which all @dfn{unsafe} octets
+@cindex unsafe
+(as defined in RFC 2396) have been @samp{%} @dfn{escaped}.
+@cindex escaped
+@code{uric:decode} decodes strings encoded by @code{uric:encode}.
+@end defun
+
+@defun uric:decode uri-component
+Returns a copy of the string @var{uri-component} in which each @samp{%} escaped
+characters in @var{uri-component} is replaced with the character it encodes. This
+routine is useful for showing URI contents on error pages.
+@end defun
diff --git a/version.txi b/version.txi
index 7766bb1..0341eab 100644
--- a/version.txi
+++ b/version.txi
@@ -1,2 +1,2 @@
-@set SLIBVERSION 2c5
-@set SLIBDATE January 1999
+@set SLIBVERSION 2d2
+@set SLIBDATE July 2001
diff --git a/vscm.init b/vscm.init
index f642ba0..b45fa7e 100644
--- a/vscm.init
+++ b/vscm.init
@@ -44,8 +44,8 @@
(define (scheme-implementation-type) 'Vscm)
-;;; (scheme-implementation-home-page) should return a (string) URL
-;;; (Uniform Resource Locator) for this scheme implementation's home
+;;; (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)
@@ -97,64 +97,73 @@
;(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.
+
+ ;; Scheme report features
+
+; rev5-report ;conforms to
+; eval ;R5RS 2-argument eval
+ values ;R5RS multiple values
+; dynamic-wind ;R5RS dynamic-wind
+; macro ;R5RS high level macros
+ delay ;has DELAY and FORCE
+ multiarg-apply ;APPLY can take more than 2 args.
+; char-ready?
+ rationalize
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
+
+ rev4-report ;conforms to
+
+ ieee-p1178 ;conforms to
+
+; rev3-report ;conforms to
+
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
+; object-hash ;has OBJECT-HASH
+
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
+ ieee-floating-point ;conforms to IEEE Standard 754-1985
+ ;IEEE Standard for Binary
+ ;Floating-Point Arithmetic.
full-continuation ;can return multiple times
-; object-hash ;has OBJECT-HASH
+ ;; Other common features
+
+; srfi ;srfi-0, COND-EXPAND finds all srfi-*
+; sicp ;runs code from Structure and
+ ;Interpretation of Computer
+ ;Programs by Abelson and Sussman.
+ defmacro ;has Common Lisp DEFMACRO
+; record ;has user defined data structures
+ string-port ;has CALL-WITH-INPUT-STRING and
+ ;CALL-WITH-OUTPUT-STRING
; sort
-; queue ;queues
; pretty-print
object->string
-; format
+; format ;Common-lisp output formatting
; 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
))
;;; (OBJECT->STRING obj) -- analogous to WRITE
(define object->string string-write)
;;; (PROGRAM-ARGUMENTS)
-;;;
+;;;
(define (program-arguments) command-line-arguments)
;;; (OUTPUT-PORT-WIDTH <port>)
@@ -252,6 +261,13 @@
(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)
@@ -320,12 +336,14 @@
(define slib:warn
(lambda args
- (let ((port (current-error-port)))
- (display "Warn: " port)
- (for-each (lambda (x) (display x port)) 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.
diff --git a/withfile.scm b/withfile.scm
index fc13510..43e9300 100644
--- a/withfile.scm
+++ b/withfile.scm
@@ -1,9 +1,9 @@
; "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.
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
diff --git a/wttest.scm b/wttest.scm
index cc8b5e3..9b1304d 100644
--- a/wttest.scm
+++ b/wttest.scm
@@ -1,35 +1,37 @@
-;; "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.
+;;; "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 and modify
+;;; this software, to redistribute either the original software or a
+;;; modified version, and to use this software for any purpose 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)
diff --git a/wttree.scm b/wttree.scm
index 515563f..cb7ca13 100644
--- a/wttree.scm
+++ b/wttree.scm
@@ -1,44 +1,44 @@
-;; "wttree.scm" Weight balanced trees -*-Scheme-*-
-;; Copyright (c) 1993-1994 Stephen Adams
-;;
-;; $Id: wttree.scm,v 1.3 1999/10/11 03:36:29 jaffer 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.
+;;; "wttree.scm" Weight balanced trees -*-Scheme-*-
+;;; Copyright (c) 1993-1994 Stephen Adams
+;;;
+;;; References:
+;;;
+;;; Stephen Adams, Implemeting Sets Efficiently in a Functional
+;;; Language, CSTR 92-10, Department of Electronics and Computer
+;;; Science, University of Southampton, 1992
+;;;
+;;;
+;;; Copyright (c) 1993-94 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy and modify
+;;; this software, to redistribute either the original software or a
+;;; modified version, and to use this software for any purpose 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@@ -63,7 +63,7 @@
;;
;;(declare (usual-integrations))
-(define error
+(define error:error
(case (scheme-implementation-type)
((MITScheme) error)
(else slib:error)))
@@ -373,7 +373,7 @@
(loop node index))))
(define (error:empty owner)
- (error "Operation requires non-empty tree:" owner))
+ (error:error "Operation requires non-empty tree:" owner))
(define (local:make-wt-tree-type key<?)
@@ -617,8 +617,8 @@
(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))))
+ (error:error "The trees" tree1 'and tree2 'have 'incompatible 'types
+ (tree/type tree1) 'and (tree/type tree2))))
;;;______________________________________________________________________
;;;
diff --git a/yasyn.scm b/yasyn.scm
index 2b3cec0..d711cc2 100644
--- a/yasyn.scm
+++ b/yasyn.scm
@@ -1,5 +1,7 @@
-;;"yasyn.scm" YASOS in terms of "object.scm"
-;;;From: whumeniu@datap.ca (Wade Humeniuk)
+;;;"yasyn.scm" YASOS in terms of "object.scm"
+;;; Author: Wade Humeniuk <humeniuw@cadvision.com>
+;;;
+;;; This code is in the public domain.
(require 'object)