From 87b82b5822ca54228cfa6df29be3ad9d4bc47d16 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:28 -0800 Subject: Import Upstream version 2d2 --- ANNOUNCE | 114 +- Bev2slib.scm | 6 +- COPYING | 37 + ChangeLog | 675 +++++++++- DrScheme.init | 6 + FAQ | 10 +- Makefile | 195 +-- README | 172 ++- RScheme.init | 92 +- STk.init | 92 +- Template.scm | 116 +- alist.scm | 6 +- alistab.scm | 23 +- array.scm | 471 +++---- arraymap.scm | 6 +- batch.scm | 6 +- bigloo.init | 178 ++- break.scm | 24 +- chap.scm | 8 +- charplot.scm | 65 +- chez.init | 100 +- cltime.scm | 8 +- coerce.scm | 107 ++ coerce.txi | 12 + comlist.scm | 375 +++--- comparse.scm | 6 +- cring.scm | 6 +- db2html.scm | 463 +++++++ db2html.txi | 185 +++ dbrowse.scm | 6 +- dbutil.scm | 74 +- debug.scm | 70 +- defmacex.scm | 10 +- differ.scm | 222 ++++ dwindtst.scm | 6 +- dynwind.scm | 6 +- elk.init | 89 +- eval.scm | 6 +- factor.scm | 8 +- factor.txi | 56 + fft.scm | 6 +- fluidlet.scm | 6 +- fmtdoc.txi | 2 +- format.scm | 1 + gambit.init | 33 +- genwrite.scm | 32 +- getopt.scm | 6 +- getparam.scm | 201 ++- glob.scm | 9 +- guile.init | 4 + hash.scm | 6 +- hashtab.scm | 6 +- htmlform.scm | 1128 ++++++---------- htmlform.txi | 205 +++ http-cgi.scm | 440 +++++++ http-cgi.txi | 112 ++ lineio.scm | 8 +- lineio.txi | 45 + logical.scm | 8 +- macscheme.init | 86 +- makcrc.scm | 49 +- mbe.scm | 6 +- minimize.scm | 114 ++ minimize.txi | 48 + mitcomp.pat | 1466 --------------------- mitscheme.init | 104 +- mklibcat.scm | 25 +- modular.scm | 8 +- mulapply.scm | 6 +- mularg.scm | 2 + nclients.scm | 20 +- nclients.txi | 103 ++ obj2str.scm | 23 +- obj2str.txi | 9 + object.scm | 4 +- paramlst.scm | 33 +- plottest.scm | 6 +- pnm.scm | 213 +++ pp.scm | 15 +- ppfile.scm | 6 +- prec.scm | 10 +- printf.scm | 366 +++--- priorque.scm | 8 +- process.scm | 8 +- pscheme.init | 458 ++++--- psxtime.scm | 8 +- qp.scm | 8 +- r4rsyn.scm | 5 +- randinex.scm | 28 +- randinex.txi | 56 + random.scm | 10 +- random.txi | 55 + ratize.scm | 26 +- rdms.scm | 41 +- recobj.scm | 4 +- record.scm | 59 +- repl.scm | 6 +- report.scm | 6 +- require.scm | 55 +- root.scm | 6 +- s48-0_57.init | 381 ++++++ sc2.scm | 8 +- sc4opt.scm | 8 +- sc4sc3.scm | 6 +- scanf.scm | 32 +- scheme2c.init | 108 +- scheme48.init | 216 +++- schmooz.scm | 56 +- schmooz.texi | 104 ++ scmacro.scm | 6 +- scmactst.scm | 160 --- scsh.init | 30 +- simetrix.scm | 246 ++++ slib.info | 3915 +++++++++++++++++++++++++++++++++++++------------------- slib.spec | 97 ++ slib.texi | 1916 ++++++++++++++++----------- srfi-1.scm | 253 ++++ srfi.scm | 83 ++ strcase.scm | 22 +- strport.scm | 6 +- struct.scm | 165 --- structst.scm | 37 - syncase.sh | 0 synchk.scm | 5 +- synclo.scm | 5 +- synrul.scm | 5 +- t3.init | 98 +- tek40.scm | 6 +- tek41.scm | 6 +- timezone.scm | 8 +- trace.scm | 254 +++- tree.scm | 53 +- trnscrpt.scm | 6 +- tzfile.scm | 6 +- umbscheme.init | 30 +- uri.scm | 319 +++++ uri.txi | 95 ++ version.txi | 2 + vscm.init | 84 +- withfile.scm | 8 +- wttest.scm | 66 +- wttree.scm | 90 +- yasyn.scm | 6 +- 143 files changed, 12094 insertions(+), 6857 deletions(-) create mode 100644 COPYING create mode 100644 DrScheme.init create mode 100644 coerce.scm create mode 100644 coerce.txi create mode 100644 db2html.scm create mode 100644 db2html.txi create mode 100644 differ.scm create mode 100644 factor.txi create mode 100644 guile.init create mode 100644 htmlform.txi create mode 100644 http-cgi.scm create mode 100644 http-cgi.txi create mode 100644 lineio.txi create mode 100644 minimize.scm create mode 100644 minimize.txi delete mode 100644 mitcomp.pat create mode 100644 nclients.txi create mode 100644 obj2str.txi create mode 100644 pnm.scm create mode 100644 randinex.txi create mode 100644 random.txi create mode 100644 s48-0_57.init create mode 100644 schmooz.texi delete mode 100644 scmactst.scm create mode 100644 simetrix.scm create mode 100644 slib.spec create mode 100644 srfi-1.scm create mode 100644 srfi.scm delete mode 100644 struct.scm delete mode 100644 structst.scm mode change 100644 => 100755 syncase.sh create mode 100644 uri.scm create mode 100644 uri.txi create mode 100644 version.txi 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 + * gambit.init: (set-case-conversion! #t) + * scheme48.init (defmacro): Defmacro in terms of define-syntax + using defmacro:expand*. + +From Wade Humeniuk + * 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 +Fri Jul 27 19:54:00 EDT 2001 Aubrey Jaffer + + * require.scm (*SLIB-VERSION*): Bumped from 2d1 to 2d2. + +2001-07-27 Aubrey Jaffer + + * s48-0_57.init: Added. + +2001-07-24 Aubrey Jaffer + + * 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 + + * 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 + + * array.scm: Rewritten to sidestep license issues. + (array=?): Added. + + * slib.texi (Arrays): Documentation integrated with array.scm. + +2001-06-28 Aubrey Jaffer + + * tree.scm (tree:subst): Rewritten; takes optional equality + predicate argument. + +2001-06-21 Aubrey Jaffer + + * Makefile (docfiles): Added "COPYING". + +2001-06-19 Aubrey Jaffer + + * mitcomp.pat: Unmaintained; removed. + + * RScheme.init: Put in the public domain. + +2001-06-11 Jacques Mequin + + * gambit.init: (set-case-conversion! #t) + +2001-06-07 Aubrey Jaffer + + * 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 + + * scheme48.init (defmacro): Defmacro in terms of define-syntax + using defmacro:expand*. + +1998-09-28 Wade Humeniuk + + * yasyn.scm, object.scm, recobj.scm: Placed in public domain. + +2001-05-31 Aubrey Jaffer + + * scmactst.scm: Removed for lack of license. + + * struct.scm, structst.scm: Removed. struct.scm lacks license. + +2001-05-29 Aubrey Jaffer + + * scheme48.init (atan): Added workaround. + + * Makefile (slib48-0.55): Makes slib48, but fluid-let broken. + +2001-05-28 Aubrey Jaffer + + * 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 + + * slib.texi (Installation): Added specific instructions for + DrScheme, MIT-Scheme, and Guile. + + * guile.init: Added. + +2001-05-19 Aubrey Jaffer + + * require.scm (program-vicinity): Improved error message. + + * slib.texi (Installation): Explicit instructions for MzScheme. + +2001-05-15 Aubrey Jaffer + + * Makefile (pdf): Added target for creating $(htmldir)slib.pdf. + +2001-04-26 Aubrey Jaffer + + * slib.texi (Installation): Expanded instructions. + +2001-04-15 Aubrey Jaffer + + * 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 + + * srfi-1.scm: Added. + + * comlist.scm (comlist:remove): Returns don't disturb order. + +2001-04-10 Aubrey Jaffer + + * array.scm: Generalized so strings and vectors are arrays. + + * slib.texi (Standard Formatted Output): %b was missing. + +2001-04-05 Aubrey Jaffer + + * 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 + + * differ.scm: An O(NP) Sequence Comparison Algorithm. + +2001-03-29 Aubrey Jaffer + + * srfi.scm (cond-expand): Added. + +2001-03-23 Aubrey Jaffer + + * wttree.scm (error:error): Replaces error. + +2001-03-21 Aubrey Jaffer + + * dbutil.scm (make-defaulter): number defaults to 0. + +2001-03-18 Aubrey Jaffer + + * Makefile (rpm): Fixed dependencies. + +Thu Mar 15 20:52:30 EST 2001 Aubrey Jaffer + + * require.scm (*SLIB-VERSION*): Bumped from 2c9 to 2d1. + +2001-03-15 Aubrey Jaffer + + * Makefile (rpm): Added to dist target. + (mfiles): Added slib.spec. + +2001-03-15 Radey Shouman + + * slib.spec: Added spec file to generate a .rpm file. + Largely based on that of Dr. Robert J. Meier + + +2001-03-13 Aubrey Jaffer + + * 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 + + * coerce.scm (type-of): Removed 'null; broke (coerce '() 'string). + +2001-03-09 Aubrey Jaffer + + * htmlform.scm (html:meta, html:http-equiv): Added. + +2001-03-04 Aubrey Jaffer + + * htmlform.scm (html:meta-refresh): Added. + +2001-02-28 Aubrey Jaffer + + * 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 + + * 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 + + * 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 + + * coerce.scm (coerce, type-of): Extracted from comlist.scm. + +2001-02-16 Aubrey Jaffer + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * db2html.scm (command:modify-table, command:make-editable-table): + (HTML editing tables): Added. + + * htmlform.scm (form:submit): Enhanced. + +2001-01-30 Aubrey Jaffer + + * 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 + + * 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 + + * uri.scm: Added collected URI functions from "http-cgi.scm" and + "db2html.scm". + +2001-01-25 Aubrey Jaffer + + * 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 + + * http-cgi.scm (query-alist->parameter-list): Made robust for + unexpected option-names; and generates warning. + +2001-01-23 Aubrey Jaffer + + * db2html.scm: Fixed HTML per http://validator.w3.org/check. + +2001-01-20 Aubrey Jaffer + + * simetrix.scm (SI:conversion-factor): Negative return codes. + +2001-01-16 Aubrey Jaffer + + * 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 + + * simetrix.scm (SI:unit-infos): Updated eV and u from CODATA-1998. + (SI:solidus): Abstracted parse functions. + +2001-01-14 Aubrey Jaffer + + * simetrix.scm: SI Metric Interchange Format for Scheme Added. + +2001-01-11 Aubrey Jaffer + + * scanf.scm (stdio:scan-and-set read-ui): Fixed dependence on LET + evaluation order. + +2001-01-04 Ben Goetter + + * pscheme.init: Revised. + +2001-01-04 Lars Arvestad + + * gambit.init (*features*): Gambit 3.0 provides + call-with-input-string and call-with-output-string. + +2000-12-21 Aubrey Jaffer + + * schmooz.texi: Split out from slib.texi. + +2000-12-13 Radey Shouman + + * printf.scm (stdio:parse-float): Adjust so %e format prints an + exponent of zero for 0.0 + +2000-12-12 Aubrey Jaffer + + * dbutil.scm (dbutil:list-table-definition): Added. + +2000-12-11 Aubrey Jaffer + + * db2html.scm (html:caption): Split out from html:table. + +2000-12-04 Aubrey Jaffer + + * rdms.scm (sync-database): Added. + +2000-10-30 Aubrey Jaffer + + * pnm.scm (pnm:array-write): PGMs were always being written with + 15 for maxval. + +2000-10-22 Aubrey Jaffer + + * 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
tags. + +2000-10-16 Aubrey Jaffer + + * 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 + + * 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 + + * htmlform.scm (html:generate-form): was ignoring method. + +Sat Oct 7 23:09:40 EDT 2000 Aubrey Jaffer + + * require.scm (*SLIB-VERSION*): Bumped from 2c8 to 2c9. + +2000-10-07 Aubrey Jaffer + + * slib.texi (Installation): Instructions cataloged by + implementation. + +2000-10-03 Aubrey Jaffer + + * DrScheme.init: Added support for DrScheme. + +2000-09-28 Aubrey Jaffer + + * http-cgi.scm (form:split-lines): Don't return empty strings. + +2000-09-27 Aubrey Jaffer + + * http-cgi.scm (form-urlencoded->query-alist): Don't convert empty + strings to #f. + +2000-09-26 Aubrey Jaffer + + * 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 + + * 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 + + * randinex.scm (random:solid-sphere!): Return radius. + +2000-09-10 Aubrey Jaffer + + * htmlform.scm: Major rewrite. html: procedures now return + strings. + + * db2html.scm: Moved html table functions from htmlform.scm. + +2000-08-06 Aubrey Jaffer + + * 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 + + * charplot.scm (find-scale): Pick arbitrary scale when data has + range of zero. + (plot-function!): Added. + +2000-06-24 Colin Walters + + * 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 + + * pnm.scm: PNM image file functions added. + +2000-06-25 Aubrey Jaffer + + * charplot.scm (charplot:iplot!): Fixed label and axis bug. + +Sat Jun 3 21:26:32 EDT 2000 Aubrey Jaffer + + * require.scm (*SLIB-VERSION*): Bumped from 2c7 to 2c8. + +2000-05-30 Aubrey Jaffer + + * 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 + + * schmooz.scm (schmooz-tops): Removed gratuitous newlines in texi + output. + +2000-04-22 Aubrey Jaffer + + * 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 + + * htmlform.scm (html:start-table): Don't force full width. + (http:serve-uri): Added. + + * db2html.scm: Added. + +2000-03-28 Lars Arvestad + + * minimize.scm (golden-section-search): Added. + +2000-03-20 Aubrey Jaffer + + * genwrite.scm (generic-write, generic-write): Down-cased QUOTE + symbol names (for guile). + +2000-02-14 Radey Shouman + + * schmooz.scm (schmooz-tops): Now reads (and ignores) #! comments. + +2000-02-05 Aubrey Jaffer + + * trace.scm (untrack, unstack): Added. + (print-call-stack): Protected bindings. + +2000-01-27 + + * Makefile (slib.info): Conditionalize infobar. + +2000-01-26 Aubrey Jaffer + + * require.scm (require:provided?): Don't catalog:get if not + *catalog*. + +2000-01-24 Radey Shouman + + * 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 + + * 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 + + * trace.scm (call-stack-news?): Fixed polarity error. + (debug:trace-procedure): made counts 1-based. + +2000-01-02 Aubrey Jaffer + + * 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 + + * 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 + + * mklibcat.scm: Added jfilter. + + * slib.texi (Extra-SLIB Packages): Added jfilter. + +Sun Dec 5 19:54:35 EST 1999 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c6 to 2c7. -1999-12-04 Aubrey Jaffer +1999-12-04 Aubrey Jaffer * 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 * printf.scm (%g): Make precision threshold work for both fractions and integers. -1999-12-03 Aubrey Jaffer +1999-12-03 Aubrey Jaffer * nclients.scm (browse-url-netscape): Try running netscape in background. -1999-11-14 Aubrey Jaffer +1999-11-14 Aubrey Jaffer * batch.scm (write-batch-line): Added slib:warn. -1999-11-01 Aubrey Jaffer +1999-11-01 Aubrey Jaffer * paramlst.scm (check-parameters): Improved warning. -1999-10-31 Aubrey Jaffer +1999-10-31 Aubrey Jaffer * 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 * glob.scm (replace-suffix): Now works. -1999-09-17 Aubrey Jaffer +1999-09-17 Aubrey Jaffer * slib.texi: Put description and URL into slib_toc.html. -Sun Sep 12 22:45:01 EDT 1999 Aubrey Jaffer +Sun Sep 12 22:45:01 EDT 1999 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c5 to 2c6. -1999-07-08 Aubrey Jaffer +1999-07-08 Aubrey Jaffer * 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 * alistab.scm (open-base): Check file exists before opening it. -1999-01-21 Aubrey Jaffer +1999-01-21 Aubrey Jaffer * 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 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 +Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c4 to 2c5. -1999-01-12 Aubrey Jaffer +1999-01-12 Aubrey Jaffer * 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 * random.scm (seed->random-state): added. -1999-01-08 Aubrey Jaffer +1999-01-08 Aubrey Jaffer * mitscheme.init (object->limited-string): Added. * random.scm (random:random): Fixed embarrassingly stupid bug. -1999-01-07 Aubrey Jaffer +1999-01-07 Aubrey Jaffer * alistab.scm (supported-key-type?): number now allowed. @@ -320,7 +943,7 @@ Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer * slib.texi (Copyrights): Added HTML anchor for Copying information. (Installation): Added HTML anchor for Installation instructions. -1998-12-02 Aubrey Jaffer +1998-12-02 Aubrey Jaffer * fluidlet.scm (fluid-let): Rewritten as defmacro. @@ -339,11 +962,11 @@ Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer * nclients.scm (glob-pattern?): Added. -1998-11-24 Aubrey Jaffer +1998-11-24 Aubrey Jaffer * htmlform.scm (html:href-heading): simplified. -1998-11-16 Aubrey Jaffer +1998-11-16 Aubrey Jaffer * 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 * rdms.scm (make-relational-system): column-foreign-list split into column-foreign-check-list and column-foreign-list. -1998-11-12 Aubrey Jaffer +1998-11-12 Aubrey Jaffer * lineio.scm (display-file): added. Schmoozed docs. @@ -378,14 +1001,14 @@ Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer if a continuation captured in the body is invoked. Now agrees with MIT Scheme documentation. -1998-11-11 Aubrey Jaffer +1998-11-11 Aubrey Jaffer * nclients.scm: Added net-clients. * require.scm (vicinity:suffix?): Abstracted from program-vicinity. -1998-11-04 Aubrey Jaffer +1998-11-04 Aubrey Jaffer * comlist.scm (remove-duplicates): added. (adjoin): memq -> memv. @@ -408,7 +1031,7 @@ Tue Nov 3 17:47:32 EST 1998 Aubrey Jaffer caused ctime to print out things in GMT, instead of using the local time. -1998-10-01 Aubrey Jaffer +1998-10-01 Aubrey Jaffer * 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 * primes.scm: removed. -1998-09-29 Aubrey Jaffer +1998-09-29 Aubrey Jaffer * 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 * batch.scm (batch:port parms): enabled warning. -1998-09-28 Aubrey Jaffer +1998-09-28 Aubrey Jaffer * 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 * schmooz.scm, htmlform.scm, admin.scm, glob.scm, ChangeLog: Cleaned a bit. -1998-09-28 Aubrey Jaffer +1998-09-28 Aubrey Jaffer * slib.texi (most-positive-fixnum): fixed description. @@ -584,7 +1207,7 @@ Tue Nov 3 17:47:32 EST 1998 Aubrey Jaffer Fri Jun 5 16:01:26 EDT 1998 Aubrey Jaffer -o * require.scm (*SLIB-VERSION*): Bumped from 2c1 to 2c2. + * require.scm (*SLIB-VERSION*): Bumped from 2c1 to 2c2. 1998-06-04 Aubrey Jaffer @@ -853,7 +1476,7 @@ Sat Aug 23 11:35:20 1997 Aubrey Jaffer * selfset.scm: added. (define a 'a) .. (define z 'z). -Sat Aug 23 09:32:44 EDT 1997 Aubrey Jaffer +Sat Aug 23 09:32:44 EDT 1997 Aubrey Jaffer * 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 +;; 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 + 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 `', + + 1. `cd' to the SLIB directory + + 2. type `make prefix= slib48'. + + 3. To install the image, type `make 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 `', `cd' to the SLIB directory and type `make -prefix= slib48'. To install the image, type `make -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 ) getenv ;posix (getenv ) ; 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 ) @@ -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 ) getenv ;posix (getenv ) ; 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 ) @@ -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 ) getenv ;posix (getenv ) ; 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 ) @@ -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 ) + (slib:eval-load defmacro:eval)) + (define (slib:eval-load evl) (if (not (file-exists? )) (set! (string-append (scheme-file-suffix)))) @@ -213,17 +237,17 @@ (evl o)) (set! *load-pathname* old-load-pathname))))) -(define (defmacro:load ) - (slib:eval-load 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 ) + getenv ;posix (getenv ) +; 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 ) (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 ) getenv ;posix (getenv ) ; 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 ) 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 +;;; 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 "\\n" (or options "")) + (append rows (list (sprintf #f "
\\n"))))) + +;;@args caption align +;;@args caption +;;@2 can be @samp{top} or @samp{bottom}. +(define (html:caption caption . align) + (if (null? align) + (sprintf #f " %s\\n" + (html:plain caption)) + (sprintf #f " %s\\n" + (car align) + (html:plain caption)))) + +;;@body Outputs a heading row for the currently-started table. +(define (html:heading columns) + (sprintf #f " \\n%s \\n" + (apply string-append + (map (lambda (datum) + (sprintf #f " %s\\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 "" (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 "" (substring str 0 len) "")) + (else (html:pre str)))))) + (sprintf #f " \\n%s \\n" + (apply string-append + (map (lambda (idx datum foreign) + (sprintf + #f " %s%s\\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 " \\n%s \\n" + (apply string-append + (map (lambda (datum foreign) + (sprintf #f " %s%s\\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 " \\n %s%s\\n \\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 " %s\\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 "" (substring str 0 len) "")) + (else (html:pre str)))))))) + (lambda (row) + (string-append + (sprintf #f " \\n%s \\n" + (apply string-append + (map (lambda (idx datum foreign) + (sprintf + #f " %s%s\\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 "%s" + 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, +;;E. Myers, U. Manber, and W. Miller, +;; +;;"An O(NP) Sequence Comparison Algorithm," +;;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 ) + getenv ;posix (getenv ) + 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 ) ; getenv ;posix (getenv ) 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)) - "&" "&" - "<" "<" - ">" ">"))) +(define (html:plain txt) ; plain-text `Data Characters' + (cond ((eq? html:blank txt) " ") + (else + (if (symbol? txt) (set! txt (symbol->string txt))) + (if (number? txt) + (number->string txt) + (string-subst (if (string? txt) txt (object->string txt)) + "&" "&" + "<" "<" + ">" ">"))))) + +;;@body Returns a tag of meta-information suitable for passing as the +;;third argument to @code{html:head}. The tag produced is @samp{}. 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" 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{}. 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" + 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" delay) + (sprintf #f "\n" + 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{} -;;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{} section. +(define (html:head title . args) (define backlink (if (null? args) #f (car args))) (if (not (null? args)) (set! args (cdr args))) - (html:printf "\\n") - (html:printf "\\n") - (html:comment "HTML by SLIB" - "http://swissnet.ai.mit.edu/~jaffer/SLIB.html") - (html:printf "%s%s\\n" - (apply string-append args) (make-plain title)) - (html:printf "

%s

\\n" - (or backlink (make-plain title)))) - -;;@body Outputs HTML codes to end a page. -(define (html:end-page) - (html:printf "\\n") - (html:printf "\\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{}) -;;within @2 will be visible verbatim. + (string-append + (sprintf #f "\\n") + (sprintf #f "\\n") + (sprintf #f "%s" + (html:comment "HTML by SLIB" + "http://swissnet.ai.mit.edu/~jaffer/SLIB.html")) + (sprintf #f " \\n %s\\n %s\\n \\n" + (html:plain title) (apply string-append args)) + (sprintf #f "

%s

\\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 "\\n\\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{}) within @2 will be visible verbatim. (define (html:pre line1 . lines) - (html:printf "
\\n%s" (make-plain line1))
-  (for-each (lambda (line) (html:printf "\\n%s" (make-plain line))) lines)
-  (html:printf "
\\n")) - -;;@body Writes (using @code{html:printf}) the strings @1 as HTML -;;comments. + (sprintf #f "
\\n%s%s
" + (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 "\\n")) - -;;@section HTML Tables - -;;@body -(define (html:start-table caption) - (html:printf "\\n") - (html:printf "\\n" (make-plain caption))) - -;;@body -(define (html:end-table) - (html:printf "
%s
\\n")) - -;;@body Outputs a heading row for the currently-started table. -(define (html:heading columns) - (html:printf "\\n") - (for-each (lambda (datum) (html:printf "%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 "%s" 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 - "
\\n%s
\\n" - (make-plain (call-with-output-string - (lambda (port) - (pretty-print datum port)))))))) - (html:printf "") - (for-each (lambda (datum foreign) - (html:printf "") - (cond ((not datum)) - ((null? datum)) - ((not anchored?) - (html:printf "= 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 "" foreign) - (present datum) - (html:printf "")) - (else - (html:printf "" - foreign (make-atval datum)) - (present datum) - (html:printf "")))) - 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 "%s" - 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 "