aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commit87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (patch)
tree1eb4f87abd38bea56e08335d939e8171d5e7bfc7
parentbd9733926076885e3417b74de76e4c9c7bc56254 (diff)
downloadslib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.zip
slib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.tar.gz
Import Upstream version 2d2upstream/2d2
-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--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--debug.scm70
-rw-r--r--defmacex.scm10
-rw-r--r--differ.scm222
-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.txi56
-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.txi205
-rw-r--r--http-cgi.scm440
-rw-r--r--http-cgi.txi112
-rw-r--r--lineio.scm8
-rw-r--r--lineio.txi45
-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.txi103
-rw-r--r--obj2str.scm23
-rw-r--r--obj2str.txi9
-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.txi56
-rw-r--r--random.scm10
-rw-r--r--random.txi55
-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.texi1916
-rw-r--r--srfi-1.scm253
-rw-r--r--srfi.scm83
-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.txi2
-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
143 files changed, 12094 insertions, 6857 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 dd11471..30a16b2 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 = /usr/local
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/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/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/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
new file mode 100644
index 0000000..38c0dd1
--- /dev/null
+++ b/factor.txi
@@ -0,0 +1,56 @@
+
+@defvar prime:prngs
+
+@var{prime:prngs} is the random-state (@pxref{Random Numbers}) used by these
+procedures. If you call these procedures from more than one thread
+(or from interrupt), @code{random} may complain about reentrant
+calls.
+@end defvar
+@emph{Note:} The prime test and generation procedures implement (or
+use) the Solovay-Strassen primality test. See
+
+@itemize @bullet
+@item Robert Solovay and Volker Strassen,
+@cite{A Fast Monte-Carlo Test for Primality},
+SIAM Journal on Computing, 1977, pp 84-85.
+@end itemize
+
+
+@defun jacobi-symbol p q
+
+Returns the value (+1, @minus{}1, or 0) of the Jacobi-Symbol of
+exact non-negative integer @var{p} and exact positive odd integer @var{q}.
+@end defun
+
+@defvar prime:trials
+
+@var{prime:trials} the maxinum number of iterations of Solovay-Strassen that will
+be done to test a number for primality.
+@end defvar
+
+@defun prime? n
+
+Returns @code{#f} if @var{n} is composite; @code{#t} if @var{n} is prime.
+There is a slight chance @code{(expt 2 (- prime:trials))} that a
+composite will return @code{#t}.
+@end defun
+
+@defun primes< start count
+
+Returns a list of the first @var{count} prime numbers less than
+@var{start}. If there are fewer than @var{count} prime numbers
+less than @var{start}, then the returned list will have fewer than
+@var{start} elements.
+@end defun
+
+@defun primes> start count
+
+Returns a list of the first @var{count} prime numbers greater than @var{start}.
+@end defun
+
+@defun factor k
+
+Returns a list of the prime factors of @var{k}. The order of the
+factors is unspecified. In order to obtain a sorted list do
+@code{(sort! (factor @var{k}) <)}.
+@end defun
diff --git a/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 c7ce1dc..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
- ((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 (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 (string-index txt #\=)
- (string-index txt #\=)))
- ((not edx) lst)
- (let* ((rxt (substring txt (+ 1 edx) (string-length txt)))
- (adx (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 (string-index line #\:)))
- (if (char-whitespace? (string-ref line (+ -1 len)))
- (set! len (+ -1 len)))
- (and idx (do ((idx2 (+ idx 1) (+ idx2 1)))
- ((or (>= idx2 len)
- (not (char-whitespace? (string-ref line idx2))))
- (set! alist
- (cons
- (cons (string-ci->symbol (substring line 0 idx))
- (substring line idx2 len))
- alist)))))
- ;;Else -- ignore malformed line
- ;;(else (slib:error 'http:read-header 'malformed-input line))
- )))
-
-(define (http:read-query-string request-line header port)
- (case (car request-line)
- ((get head)
- (let* ((request-uri (cadr request-line))
- (len (string-length request-uri)))
- (and (> len 3)
- (string-index request-uri #\?)
- (substring request-uri
- (+ 1 (string-index request-uri #\?))
- (if (eqv? #\/ (string-ref request-uri (+ -1 len)))
- (+ -1 len)
- len)))))
- ((post put delete)
- (let ((content-length (assq 'content-length header)))
- (and content-length
- (set! content-length (string->number (cdr content-length))))
- (and content-length
- (let ((str (make-string content-length #\ )))
- (do ((idx 0 (+ idx 1)))
- ((>= idx content-length)
- (if (>= idx (string-length str)) str (substring str 0 idx)))
- (let ((chr (read-char port)))
- (if (char? chr)
- (string-set! str idx chr)
- (set! content-length idx))))))))
- (else #f)))
-
-(define (http: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
new file mode 100644
index 0000000..ffa0665
--- /dev/null
+++ b/htmlform.txi
@@ -0,0 +1,205 @@
+@code{(require 'html-form)}
+@ftindex html-form
+
+
+@defun html:atval txt
+Returns a string with character substitutions appropriate to
+send @var{txt} as an @dfn{attribute-value}.
+@cindex attribute-value
+@end defun
+
+@defun html:plain txt
+Returns a string with character substitutions appropriate to
+send @var{txt} as an @dfn{plain-text}.
+@cindex plain-text
+@end defun
+
+@defun html:meta name content
+Returns a tag of meta-information suitable for passing as the
+third argument to @code{html:head}. The tag produced is @samp{<META
+NAME="@var{name}" CONTENT="@var{content}">}. The string or symbol @var{name} can be
+@samp{author}, @samp{copyright}, @samp{keywords}, @samp{description},
+@samp{date}, @samp{robots}, @dots{}.
+@end defun
+
+@defun html:http-equiv name content
+Returns a tag of HTTP information suitable for passing as the
+third argument to @code{html:head}. The tag produced is @samp{<META
+HTTP-EQUIV="@var{name}" CONTENT="@var{content}">}. The string or symbol @var{name} can be
+@samp{Expires}, @samp{PICS-Label}, @samp{Content-Type},
+@samp{Refresh}, @dots{}.
+@end defun
+
+@defun html:meta-refresh delay uri
+
+
+@defunx html:meta-refresh delay
+
+Returns a tag suitable for passing as the third argument to
+@code{html:head}. If @var{uri} argument is supplied, then @var{delay} seconds after
+displaying the page with this tag, Netscape or IE browsers will fetch
+and display @var{uri}. Otherwise, @var{delay} seconds after displaying the page with
+this tag, Netscape or IE browsers will fetch and redisplay this page.
+@end defun
+
+@defun html:head title backlink tags @dots{}
+
+
+@defunx html:head title backlink
+
+@defunx html:head title
+
+Returns header string for an HTML page named @var{title}. If @var{backlink} is a string,
+it is used verbatim between the @samp{H1} tags; otherwise @var{title} is
+used. If string arguments @var{tags} ... are supplied, then they are
+included verbatim within the @t{<HEAD>} section.
+@end defun
+
+@defun html:body body @dots{}
+Returns HTML string to end a page.
+@end defun
+
+@defun html:pre line1 line @dots{}
+Returns the strings @var{line1}, @var{lines} as @dfn{PRE}formmated plain text
+@cindex PRE
+(rendered in fixed-width font). Newlines are inserted between @var{line1},
+@var{lines}. HTML tags (@samp{<tag>}) within @var{lines} will be visible verbatim.
+@end defun
+
+@defun html:comment line1 line @dots{}
+Returns the strings @var{line1} as HTML comments.
+@end defun
+@section HTML Forms
+
+
+@defun html:form method action body @dots{}
+The symbol @var{method} is either @code{get}, @code{head}, @code{post},
+@code{put}, or @code{delete}. The strings @var{body} form the body of the
+form. @code{html:form} returns the HTML @dfn{form}.
+@cindex form
+@end defun
+
+@defun html:hidden name value
+Returns HTML string which will cause @var{name}=@var{value} in form.
+@end defun
+
+@defun html:checkbox pname default
+Returns HTML string for check box.
+@end defun
+
+@defun html:text pname default size @dots{}
+Returns HTML string for one-line text box.
+@end defun
+
+@defun html:text-area pname default-list
+Returns HTML string for multi-line text box.
+@end defun
+
+@defun html:select pname arity default-list foreign-values
+Returns HTML string for pull-down menu selector.
+@end defun
+
+@defun html:buttons pname arity default-list foreign-values
+Returns HTML string for any-of selector.
+@end defun
+
+@defun form:submit submit-label command
+
+
+@defunx form:submit submit-label
+
+The string or symbol @var{submit-label} appears on the button which submits the form.
+If the optional second argument @var{command} is given, then @code{*command*=@var{command}}
+and @code{*button*=@var{submit-label}} are set in the query. Otherwise,
+@code{*command*=@var{submit-label}} is set in the query.
+@end defun
+
+@defun form:image submit-label image-src
+The @var{image-src} appears on the button which submits the form.
+@end defun
+
+@defun form:reset
+Returns a string which generates a @dfn{reset} button.
+@cindex reset
+@end defun
+
+@defun form:element pname arity default-list foreign-values
+Returns a string which generates an INPUT element for the field
+named @var{pname}. The element appears in the created form with its
+representation determined by its @var{arity} and domain. For domains which
+are foreign-keys:
+
+@table @code
+@item single
+select menu
+@item optional
+select menu
+@item nary
+check boxes
+@item nary1
+check boxes
+@end table
+
+If the foreign-key table has a field named @samp{visible-name}, then
+the contents of that field are the names visible to the user for
+those choices. Otherwise, the foreign-key itself is visible.
+
+For other types of domains:
+
+@table @code
+@item single
+text area
+@item optional
+text area
+@item boolean
+check box
+@item nary
+text area
+@item nary1
+text area
+@end table
+@end defun
+
+@defun form:delimited pname doc aliat arity default-list foreign-values
+
+
+Returns a HTML string for a form element embedded in a line of a
+delimited list. Apply map @code{form:delimited} to the list returned by
+@code{command->p-specs}.
+@end defun
+
+@defun command->p-specs rdb command-table command
+
+
+The symbol @var{command-table} names a command table in the @var{rdb} relational database.
+The symbol @var{command} names a key in @var{command-table}.
+
+@code{command->p-specs} returns a list of lists of @var{pname}, @var{doc}, @var{aliat},
+@var{arity}, @var{default-list}, and @var{foreign-values}. The
+returned list has one element for each parameter of command @var{command}.
+
+This example demonstrates how to create a HTML-form for the @samp{build}
+command.
+
+@example
+(require (in-vicinity (implementation-vicinity) "build.scm"))
+(call-with-output-file "buildscm.html"
+ (lambda (port)
+ (display
+ (string-append
+ (html:head 'commands)
+ (html:body
+ (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n"
+ (html:plain 'build)
+ (html:plain ((comtab 'get 'documentation) 'build)))
+ (html:form
+ 'post
+ (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi")
+ (apply html:delimited-list
+ (apply map form:delimited
+ (command->p-specs build '*commands* 'build)))
+ (form:submit 'build)
+ (form:reset))))
+ port)))
+@end example
+@end defun
diff --git a/http-cgi.scm b/http-cgi.scm
new file mode 100644
index 0000000..02aade3
--- /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 (string-index line #\:)))
+ (if (char-whitespace? (string-ref line (+ -1 len)))
+ (set! len (+ -1 len)))
+ (and idx (do ((idx2 (+ idx 1) (+ idx2 1)))
+ ((or (>= idx2 len)
+ (not (char-whitespace? (string-ref line idx2))))
+ (set! alist
+ (cons
+ (cons (string-ci->symbol (substring line 0 idx))
+ (substring line idx2 len))
+ alist)))))
+ ;;Else -- ignore malformed line
+ ;;(else (slib:error 'http:read-header 'malformed-input line))
+ )))
+
+(define (http:read-query-string request-line header port)
+ (case (car request-line)
+ ((get head)
+ (let* ((request-uri (cadr request-line))
+ (len (string-length request-uri)))
+ (and (> len 3)
+ (string-index request-uri #\?)
+ (substring request-uri
+ (+ 1 (string-index request-uri #\?))
+ (if (eqv? #\/ (string-ref request-uri (+ -1 len)))
+ (+ -1 len)
+ len)))))
+ ((post put delete)
+ (let ((content-length (assq 'content-length header)))
+ (and content-length
+ (set! content-length (string->number (cdr content-length))))
+ (and content-length
+ (let ((str (make-string content-length #\ )))
+ (do ((idx 0 (+ idx 1)))
+ ((>= idx content-length)
+ (if (>= idx (string-length str)) str (substring str 0 idx)))
+ (let ((chr (read-char port)))
+ (if (char? chr)
+ (string-set! str idx chr)
+ (set! content-length idx))))))))
+ (else #f)))
+
+(define (http:status-line status-code reason)
+ (sprintf #f "HTTP/1.1 %d %s%s" status-code reason http:crlf))
+
+;;@body Returns a string containing lines for each element of @1; the
+;;@code{car} of which is followed by @samp{: }, then the @code{cdr}.
+(define (http:header alist)
+ (string-append
+ (apply string-append
+ (map (lambda (pair)
+ (sprintf #f "%s: %s%s" (car pair) (cdr pair) http:crlf))
+ alist))
+ http:crlf))
+
+;;@body Returns the concatenation of strings @2 with the
+;;@code{(http:header @1)} and the @samp{Content-Length} prepended.
+(define (http:content alist . body)
+ (define hunk (apply string-append body))
+ (string-append (http:header
+ (cons (cons "Content-Length"
+ (number->string (string-length hunk)))
+ alist))
+ hunk))
+
+;;@body String appearing at the bottom of error pages.
+(define *http:byline* #f)
+
+;;@body @1 and @2 should be an integer and string as specified in
+;;@cite{RFC 2068}. The returned page (string) will show the @1 and @2
+;;and any additional @3 @dots{}; with @var{*http:byline*} or SLIB's
+;;default at the bottom.
+(define (http:error-page status-code reason-phrase . html-strings)
+ (define byline
+ (or
+ *http:byline*
+ (sprintf
+ #f
+ "<A HREF=http://swissnet.ai.mit.edu/~jaffer/SLIB.html>SLIB</A> %s server"
+ (if (getenv "SERVER_PROTOCOL") "CGI/1.1" "HTTP/1.1"))))
+ (string-append (http:status-line status-code reason-phrase)
+ (http:content
+ '(("Content-Type" . "text/html"))
+ (html:head (sprintf #f "%d %s" status-code reason-phrase))
+ (apply html:body
+ (append html-strings
+ (list (sprintf #f "<HR>\\n%s\\n" byline)))))))
+
+;;@body The string or symbol @1 is the page title. @2 is a non-negative
+;;integer. The @4 @dots{} are typically used to explain to the user why
+;;this page is being forwarded.
+;;
+;;@0 returns an HTML string for a page which automatically forwards to
+;;@3 after @2 seconds. The returned page (string) contains any @4
+;;@dots{} followed by a manual link to @3, in case the browser does not
+;;forward automatically.
+(define (http:forwarding-page title delay uri . html-strings)
+ (string-append
+ (html:head title #f (html:meta-refresh delay uri))
+ (apply html:body
+ (append html-strings
+ (list (sprintf #f "\\n\\n<HR>\\nReturn to %s.\\n"
+ (html:link uri title)))))))
+
+;;@body reads the @dfn{URI} and @dfn{query-string} from @2. If the
+;;query is a valid @samp{"POST"} or @samp{"GET"} query, then @0 calls
+;;@1 with three arguments, the @var{request-line}, @var{query-string},
+;;and @var{header-alist}. Otherwise, @0 calls @1 with the
+;;@var{request-line}, #f, and @var{header-alist}.
+;;
+;;If @1 returns a string, it is sent to @3. If @1 returns a list,
+;;then an error page with number 525 and strings from the list. If @1
+;;returns #f, then a @samp{Bad Request} (400) page is sent to @3.
+;;
+;;Otherwise, @0 replies (to @3) with appropriate HTML describing the
+;;problem.
+(define (http:serve-query serve-proc input-port output-port)
+ (let* ((request-line (http:read-request-line input-port))
+ (header (and request-line (http:read-header input-port)))
+ (query-string (and header (http:read-query-string
+ request-line header input-port))))
+ (display (http:service serve-proc request-line query-string header)
+ output-port)))
+
+(define (http:service serve-proc request-line query-string header)
+ (cond ((not request-line) (http:error-page 400 "Bad Request."))
+ ((string? (car request-line))
+ (http:error-page 501 "Not Implemented" (html:plain request-line)))
+ ((not (memq (car request-line) '(get post)))
+ (http:error-page 405 "Method Not Allowed" (html:plain request-line)))
+ ((serve-proc request-line query-string header) =>
+ (lambda (reply)
+ (cond ((string? reply)
+ (string-append (http:status-line 200 "OK")
+ reply))
+ ((and (pair? reply) (list? reply))
+ (if (number? (car reply))
+ (apply http:error-page reply)
+ (apply http:error-page 525 reply)))
+ (else (http:error-page 500 "Internal Server Error")))))
+ ((not query-string)
+ (http:error-page 400 "Bad Request" (html:plain request-line)))
+ (else
+ (http:error-page 500 "Internal Server Error" (html:plain header)))))
+
+;;@
+;;
+;;This example services HTTP queries from @var{port-number}:
+;;@example
+;;
+;;(define socket (make-stream-socket AF_INET 0))
+;;(and (socket:bind socket port-number) ; AF_INET INADDR_ANY
+;; (socket:listen socket 10) ; Queue up to 10 requests.
+;; (dynamic-wind
+;; (lambda () #f)
+;; (lambda ()
+;; (do ((port (socket:accept socket) (socket:accept socket)))
+;; (#f)
+;; (let ((iport (duplicate-port port "r"))
+;; (oport (duplicate-port port "w")))
+;; (http:serve-query build:serve iport oport)
+;; (close-port iport)
+;; (close-port oport))
+;; (close-port port)))
+;; (lambda () (close-port socket))))
+;;@end example
+
+(define (http:read-start-line port)
+ (do ((line (read-line port) (read-line port)))
+ ((or (not (equal? "" line)) (eof-object? line)) line)))
+
+;; @body
+;; Request lines are a list of three itmes:
+;;
+;; @enumerate 0
+;;
+;; @item Method
+;;
+;; A symbol (@code{options}, @code{get}, @code{head}, @code{post},
+;; @code{put}, @code{delete}, @code{trace} @dots{}).
+;;
+;; @item Request-URI
+;;
+;; A string. For direct HTTP, at the minimum it will be the string
+;; @samp{"/"}.
+;;
+;; @item HTTP-Version
+;;
+;; A string. For example, @samp{HTTP/1.0}.
+;; @end enumerate
+(define (http:read-request-line port)
+ (let ((lst (scanf-read-list "%s %s %s %s" (http:read-start-line port))))
+ (and (list? lst)
+ (= 3 (length lst))
+ (cons (string-ci->symbol (car lst)) (cdr lst)))))
+(define (cgi:request-line)
+ (define method (getenv "REQUEST_METHOD"))
+ (and method
+ (list (string-ci->symbol method)
+ (getenv "SCRIPT_NAME")
+ (getenv "SERVER_PROTOCOL"))))
+
+(define (cgi:query-header)
+ (define assqs '())
+ (cond ((and (getenv "SERVER_NAME") (getenv "SERVER_PORT"))
+ (set! assqs (cons (cons 'host (string-append (getenv "SERVER_NAME")
+ ":"
+ (getenv "SERVER_PORT")))
+ assqs))))
+ (for-each
+ (lambda (envar)
+ (define valstr (getenv envar))
+ (if valstr (set! assqs
+ (cons (cons (string-ci->symbol
+ (string-subst envar "HTTP_" "" "_" "-"))
+ valstr)
+ assqs))))
+ '(
+ ;;"AUTH_TYPE"
+ "CONTENT_LENGTH"
+ "CONTENT_TYPE"
+ "DOCUMENT_ROOT"
+ "GATEWAY_INTERFACE"
+ "HTTP_ACCEPT"
+ "HTTP_ACCEPT_CHARSET"
+ "HTTP_ACCEPT_ENCODING"
+ "HTTP_ACCEPT_LANGUAGE"
+ "HTTP_CONNECTION"
+ "HTTP_HOST"
+ ;;"HTTP_PRAGMA"
+ "HTTP_REFERER"
+ "HTTP_USER_AGENT"
+ "PATH_INFO"
+ "PATH_TRANSLATED"
+ "QUERY_STRING"
+ "REMOTE_ADDR"
+ "REMOTE_HOST"
+ ;;"REMOTE_IDENT"
+ ;;"REMOTE_USER"
+ "REQUEST_URI"
+ "SCRIPT_FILENAME"
+ "SCRIPT_NAME"
+ ;;"SERVER_SIGNATURE"
+ ;;"SERVER_SOFTWARE"
+ ))
+ assqs)
+
+;; @body Reads the @dfn{query-string} from @code{(current-input-port)}.
+;; @0 reads a @samp{"POST"} or @samp{"GET"} queries, depending on the
+;; value of @code{(getenv "REQUEST_METHOD")}.
+(define (cgi:read-query-string)
+ (define request-method (getenv "REQUEST_METHOD"))
+ (cond ((and request-method (string-ci=? "GET" request-method))
+ (getenv "QUERY_STRING"))
+ ((and request-method (string-ci=? "POST" request-method))
+ (let ((content-length (getenv "CONTENT_LENGTH")))
+ (and content-length
+ (set! content-length (string->number content-length)))
+ (and content-length
+ (let ((str (make-string content-length #\ )))
+ (do ((idx 0 (+ idx 1)))
+ ((>= idx content-length)
+ (if (>= idx (string-length str))
+ str
+ (substring str 0 idx)))
+ (let ((chr (read-char)))
+ (if (char? chr)
+ (string-set! str idx chr)
+ (set! content-length idx))))))))
+ (else #f)))
+
+;;@body reads the @dfn{URI} and @dfn{query-string} from
+;;@code{(current-input-port)}. If the query is a valid @samp{"POST"}
+;;or @samp{"GET"} query, then @0 calls @1 with three arguments, the
+;;@var{request-line}, @var{query-string}, and @var{header-alist}.
+;;Otherwise, @0 calls @1 with the @var{request-line}, #f, and
+;;@var{header-alist}.
+;;
+;;If @1 returns a string, it is sent to @code{(current-input-port)}.
+;;If @1 returns a list, then an error page with number 525 and strings
+;;from the list. If @1 returns #f, then a @samp{Bad Request} (400)
+;;page is sent to @code{(current-input-port)}.
+;;
+;;Otherwise, @0 replies (to @code{(current-input-port)}) with
+;;appropriate HTML describing the problem.
+(define (cgi:serve-query serve-proc)
+ (let* ((script-name (getenv "SCRIPT_NAME"))
+ (request-line (cgi:request-line))
+ (header (and request-line (cgi:query-header)))
+ (query-string (and header (cgi:read-query-string)))
+ (reply (http:service serve-proc request-line query-string header)))
+ (display (if (and script-name
+ (not (eqv? 0 (substring? "nph-" script-name))))
+ ;; Eat http status line.
+ (substring reply (+ 2 (substring? http:crlf reply))
+ (string-length reply))
+ reply))))
+
+(define (coerce->list str type)
+ (case type
+ ((expression)
+ (slib:warn 'coerce->list 'unsafe 'read)
+ (do ((tok (read port) (read port))
+ (lst '() (cons tok lst)))
+ ((or (null? tok) (eof-object? tok)) lst)))
+ ((symbol)
+ (call-with-input-string str
+ (lambda (port)
+ (do ((tok (scanf-read-list " %s" port)
+ (scanf-read-list " %s" port))
+ (lst '() (cons (string-ci->symbol (car tok)) lst)))
+ ((or (null? tok) (eof-object? tok)) lst)))))
+ (else
+ (call-with-input-string str
+ (lambda (port)
+ (do ((tok (scanf-read-list " %s" port)
+ (scanf-read-list " %s" port))
+ (lst '() (cons (coerce (car tok) type) lst)))
+ ((or (null? tok) (eof-object? tok)) lst)))))))
+
+(define (query-alist->parameter-list alist optnames arities types)
+ (let ((parameter-list (make-parameter-list optnames)))
+ (for-each
+ (lambda (lst)
+ (let* ((value (cadr lst))
+ (name (car lst))
+ (opt-pos (position name optnames)))
+ (cond ((not opt-pos)
+ (slib:warn 'query-alist->parameter-list
+ 'unknown 'parameter name))
+ ((eq? (list-ref arities opt-pos) 'boolean)
+ (adjoin-parameters! parameter-list (list name #t)))
+ ((and (equal? value "")
+ (not (memq (list-ref types opt-pos) '(expression string))))
+ (adjoin-parameters! parameter-list (list name #f)))
+ (value
+ (adjoin-parameters!
+ parameter-list
+ (cons name
+ (case (list-ref arities opt-pos)
+ ((nary nary1)
+ (coerce->list value (list-ref types opt-pos)))
+ (else
+ (list (coerce value (list-ref types opt-pos)))))))))))
+ alist)
+ parameter-list))
+
+;;@args rdb command-table
+;;@args rdb command-table #t
+;;
+;;Returns a procedure of one argument. When that procedure is called
+;;with a @var{query-alist} (as returned by @code{uri:decode-query}, the
+;;value of the @samp{*command*} association will be the command invoked
+;;in @2. If @samp{*command*} is not in the @var{query-alist} then the
+;;value of @samp{*suggest*} is tried. If neither name is in the
+;;@var{query-alist}, then the literal value @samp{*default*} is tried in
+;;@2.
+;;
+;;If optional third argument is non-false, then the command is called
+;;with just the parameter-list; otherwise, command is called with the
+;;arguments described in its table.
+(define (make-query-alist-command-server rdb command-table . just-params?)
+ (define comsrvcal (make-command-server rdb command-table))
+ (set! just-params? (if (null? just-params?) #f (car just-params?)))
+ (lambda (query-alist)
+ (define comnam #f)
+ (define find-command?
+ (lambda (cname)
+ (define tryp (parameter-list-ref query-alist cname))
+ (cond ((not tryp) #f)
+ (comnam
+ (set! query-alist (remove-parameter cname query-alist)))
+ (else
+ (set! query-alist (remove-parameter cname query-alist))
+ (set! comnam (string-ci->symbol (car tryp)))))))
+ (find-command? '*command*)
+ (find-command? '*suggest*)
+ (find-command? '*button*)
+ (cond ((not comnam) (set! comnam '*default*)))
+ (cond
+ (comnam
+ (comsrvcal comnam
+ (lambda (comname comval options positions
+ arities types defaulters dirs aliases)
+ (let* ((params (query-alist->parameter-list
+ query-alist options arities types))
+ (fparams (fill-empty-parameters defaulters params)))
+ (and (list? fparams)
+ (check-parameters dirs fparams)
+ (if just-params?
+ (comval fparams)
+ (let ((arglist (parameter-list->arglist
+ positions arities fparams)))
+ (and arglist
+ (apply comval arglist))))))))))))
diff --git a/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
new file mode 100644
index 0000000..34d42d5
--- /dev/null
+++ b/lineio.txi
@@ -0,0 +1,45 @@
+
+@defun read-line
+
+
+@defunx read-line port
+Returns a string of the characters up to, but not including a
+newline or end of file, updating @var{port} to point to the
+character following the newline. If no characters are available, an
+end of file object is returned. The @var{port} argument may be
+omitted, in which case it defaults to the value returned by
+@code{current-input-port}.
+@end defun
+
+@defun read-line! string
+
+
+@defunx read-line! string port
+Fills @var{string} with characters up to, but not including a newline or end
+of file, updating the @var{port} to point to the last character read
+or following the newline if it was read. If no characters are
+available, an end of file object is returned. If a newline or end
+of file was found, the number of characters read is returned.
+Otherwise, @code{#f} is returned. The @var{port} argument may be
+omitted, in which case it defaults to the value returned by
+@code{current-input-port}.
+@end defun
+
+@defun write-line string
+
+
+@defunx write-line string port
+Writes @var{string} followed by a newline to the given @var{port} and returns
+an unspecified value. The @var{Port} argument may be omitted, in
+which case it defaults to the value returned by
+@code{current-input-port}.@refill
+@end defun
+
+@defun display-file path
+
+
+@defunx display-file path port
+Displays the contents of the file named by @var{path} to @var{port}. The
+@var{port} argument may be ommited, in which case it defaults to the
+value returned by @code{current-output-port}.
+@end defun
diff --git a/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 530683d..08f3d0b 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
new file mode 100644
index 0000000..ff62436
--- /dev/null
+++ b/nclients.txi
@@ -0,0 +1,103 @@
+
+@defun call-with-tmpnam proc
+
+
+@defunx call-with-tmpnam proc k
+Calls @var{proc} with @var{k} arguments, strings returned by successive
+calls to @code{tmpnam}. If @var{proc} returns, then any files named by the
+arguments to @var{proc} are deleted automatically and the value(s) yielded
+by the @var{proc} is(are) returned. @var{k} may be ommited, in which case
+it defaults to @code{1}.
+@end defun
+
+@defun user-email-address
+
+@code{user-email-address} returns a string of the form @samp{username@r{@@}hostname}. If
+this e-mail address cannot be obtained, #f is returned.
+@end defun
+
+@defun current-directory
+
+@code{current-directory} returns a string containing the absolute file name representing
+the current working directory. If this string cannot be obtained,
+#f is returned.
+
+If @code{current-directory} cannot be supported by the platform, the value of @code{current-directory} is
+#f.
+@end defun
+
+@defun make-directory name
+
+Creates a sub-directory @var{name} of the current-directory. If successful,
+@code{make-directory} returns #t; otherwise #f.
+@end defun
+
+@defun null-directory? file-name
+
+Returns #t if changing directory to @var{file-name} makes the current working
+directory the same as it is before changing directory; otherwise
+returns #f.
+@end defun
+
+@defun absolute-path? file-name
+
+Returns #t if @var{file-name} is a fully specified pathname (does not depend on
+the current working directory); otherwise returns #f.
+@end defun
+
+@defun glob-pattern? str
+Returns #t if the string @var{str} contains characters used for
+specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}.
+@end defun
+
+@defun parse-ftp-address uri
+
+Returns a list of the decoded FTP @var{uri}; or #f if indecipherable. FTP
+@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit}
+@cindex Uniform Resource Locator
+@cindex ange-ftp
+@cindex getit
+formats are handled. The returned list has four elements which are
+strings or #f:
+
+@enumerate 0
+@item
+username
+@item
+password
+@item
+remote-site
+@item
+remote-directory
+@end enumerate
+@end defun
+
+@defun ftp-upload paths user password remote-site remote-dir
+
+@var{password} must be a non-empty string or #f. @var{paths} must be a non-empty list
+of pathnames or Glob patterns (@pxref{Filenames}) matching files to
+transfer.
+
+@code{ftp-upload} puts the files specified by @var{paths} into the @var{remote-dir} directory of FTP @var{remote-site}
+using name @var{user} with (optional) @var{password}.
+
+If @var{password} is #f and @var{user} is not @samp{ftp} or @samp{anonymous}, then @var{user} is
+ignored; FTP takes the username and password from the @file{.netrc}
+or equivalent file.
+@end defun
+
+@defun path->uri path
+
+Returns a URI-string for @var{path} on the local host.
+@end defun
+
+@defun browse-url-netscape url
+
+If a @samp{netscape} browser is running, @code{browse-url-netscape} causes the browser to
+display the page specified by string @var{url} and returns #t.
+
+If the browser is not running, @code{browse-url-netscape} runs @samp{netscape} with the
+argument @var{url}. If the browser starts as a background job, @code{browse-url-netscape} returns
+#t immediately; if the browser starts as a foreground job, then @code{browse-url-netscape}
+returns #t when the browser exits; otherwise it returns #f.
+@end defun
diff --git a/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
new file mode 100644
index 0000000..83e8b1b
--- /dev/null
+++ b/obj2str.txi
@@ -0,0 +1,9 @@
+
+@defun object->string obj
+Returns the textual representation of @var{obj} as a string.
+@end defun
+
+@defun object->limited-string obj limit
+Returns the textual representation of @var{obj} as a string of length
+at most @var{limit}.
+@end defun
diff --git a/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
new file mode 100644
index 0000000..80531eb
--- /dev/null
+++ b/randinex.txi
@@ -0,0 +1,56 @@
+
+@defun random:uniform
+
+
+@defunx random:uniform state
+Returns an uniformly distributed inexact real random number in the
+range between 0 and 1.
+@end defun
+
+@defun random:exp
+
+
+@defunx random:exp state
+Returns an inexact real in an exponential distribution with mean 1. For
+an exponential distribution with mean @var{u} use
+@w{@code{(* @var{u} (random:exp))}}.
+@end defun
+
+@defun random:normal
+
+
+@defunx random:normal state
+Returns an inexact real in a normal distribution with mean 0 and
+standard deviation 1. For a normal distribution with mean @var{m} and
+standard deviation @var{d} use
+@w{@code{(+ @var{m} (* @var{d} (random:normal)))}}.
+@end defun
+
+@defun random:normal-vector! vect
+
+
+@defunx random:normal-vector! vect state
+Fills @var{vect} with inexact real random numbers which are independent
+and standard normally distributed (i.e., with mean 0 and variance 1).
+@end defun
+
+@defun random:hollow-sphere! vect
+
+
+@defunx random:hollow-sphere! vect state
+Fills @var{vect} with inexact real random numbers the sum of whose
+squares is equal to 1.0. Thinking of @var{vect} as coordinates in space
+of dimension n = @code{(vector-length @var{vect})}, the coordinates are
+uniformly distributed over the surface of the unit n-shere.
+@end defun
+
+@defun random:solid-sphere! vect
+
+
+@defunx random:solid-sphere! vect state
+Fills @var{vect} with inexact real random numbers the sum of whose
+squares is less than 1.0. Thinking of @var{vect} as coordinates in
+space of dimension @var{n} = @code{(vector-length @var{vect})}, the
+coordinates are uniformly distributed within the unit @var{n}-shere.
+The sum of the squares of the numbers is returned.
+@end defun
diff --git a/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
new file mode 100644
index 0000000..d9474f9
--- /dev/null
+++ b/random.txi
@@ -0,0 +1,55 @@
+
+@defun random n
+
+
+@defunx random n state
+Accepts a positive integer or real @var{n} and returns a number of the
+same type between zero (inclusive) and @var{n} (exclusive). The values
+returned by @code{random} are uniformly distributed from 0 to @var{n}.
+
+The optional argument @var{state} must be of the type returned by
+@code{(seed->random-state)} or @code{(make-random-state)}. It defaults
+to the value of the variable @code{*random-state*}. This object is used
+to maintain the state of the pseudo-random-number generator and is
+altered as a side effect of calls to @code{random}.
+@end defun
+@defvar *random-state*
+Holds a data structure that encodes the internal state of the
+random-number generator that @code{random} uses by default. The nature
+of this data structure is implementation-dependent. It may be printed
+out and successfully read back in, but may or may not function correctly
+as a random-number state object in another implementation.
+@end defvar
+
+
+@defun copy-random-state state
+
+Returns a new copy of argument @var{state}.
+
+
+@defunx copy-random-state
+Returns a new copy of @code{*random-state*}.
+@end defun
+
+@defun seed->random-state seed
+
+Returns a new object of type suitable for use as the value of the
+variable @code{*random-state*} or as a second argument to @code{random}.
+The number or string @var{seed} is used to initialize the state. If
+@code{seed->random-state} is called twice with arguments which are
+@code{equal?}, then the returned data structures will be @code{equal?}.
+Calling @code{seed->random-state} with unequal arguments will nearly
+always return unequal states.
+@end defun
+
+@defun make-random-state
+
+
+@defunx make-random-state obj
+Returns a new object of type suitable for use as the value of the
+variable @code{*random-state*} or as a second argument to @code{random}.
+If the optional argument @var{obj} is given, it should be a printable
+Scheme object; the first 50 characters of its printed representation
+will be used as the seed. Otherwise the value of @code{*random-state*}
+is used as the seed.
+@end defun
diff --git a/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