From 83dff6e55f8397219e81b3f66d7d47c46c14b1cb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 13 May 2008 00:07:40 +0200 Subject: [PATCH] Update Makefile.am's; remove slib import * Makefile.am: * module/Makefile.am: * module/language/scheme/Makefile.am: * module/system/Makefile.am: * module/system/base/Makefile.am: * module/system/il/Makefile.am: * module/system/repl/Makefile.am: * module/system/vm/Makefile.am: Cleaned up to be more complete, if not completely working. * module/guile/slib.scm: * module/slib/: Removed the slib import; it's a bit out of place here, and bitrotten at that. --- Makefile.am | 1 + module/Makefile.am | 16 +- module/guile/slib.scm | 40 - module/language/scheme/Makefile.am | 7 +- module/slib/.cvsignore | 1 - module/slib/ANNOUNCE | 171 - module/slib/Bev2slib.scm | 94 - module/slib/ChangeLog | 2604 ------ module/slib/DrScheme.init | 6 - module/slib/FAQ | 217 - module/slib/Makefile | 333 - module/slib/README | 297 - module/slib/RScheme.init | 290 - module/slib/STk.init | 256 - module/slib/Template.scm | 282 - module/slib/alist.scm | 66 - module/slib/alistab.scm | 352 - module/slib/array.scm | 279 - module/slib/arraymap.scm | 78 - module/slib/batch.scm | 454 - module/slib/bigloo.init | 263 - module/slib/break.scm | 149 - module/slib/byte.scm | 15 - module/slib/chap.scm | 150 - module/slib/charplot.scm | 171 - module/slib/chez.init | 396 - module/slib/cltime.scm | 67 - module/slib/coerce.scm | 107 - module/slib/coerce.txi | 12 - module/slib/collect.scm | 236 - module/slib/comlist.scm | 328 - module/slib/comparse.scm | 99 - module/slib/cring.scm | 470 -- module/slib/db2html.scm | 463 - module/slib/db2html.txi | 185 - module/slib/dbrowse.scm | 92 - module/slib/dbutil.scm | 313 - module/slib/debug.scm | 98 - module/slib/defmacex.scm | 100 - module/slib/determ.scm | 14 - module/slib/dwindtst.scm | 80 - module/slib/dynamic.scm | 75 - module/slib/dynwind.scm | 74 - module/slib/elk.init | 303 - module/slib/eval.scm | 146 - module/slib/factor.scm | 245 - module/slib/factor.txi | 56 - module/slib/fft.scm | 70 - module/slib/fluidlet.scm | 40 - module/slib/fmtdoc.txi | 434 - module/slib/format.scm | 1675 ---- module/slib/formatst.scm | 647 -- module/slib/gambit.init | 301 - module/slib/genwrite.scm | 266 - module/slib/getopt.scm | 80 - module/slib/getparam.scm | 213 - module/slib/glob.scm | 227 - module/slib/guile.init | 232 - module/slib/hash.scm | 153 - module/slib/hashtab.scm | 79 - module/slib/htmlform.scm | 448 - module/slib/htmlform.txi | 204 - module/slib/http-cgi.scm | 438 - module/slib/http-cgi.txi | 110 - module/slib/lineio.scm | 82 - module/slib/lineio.txi | 45 - module/slib/logical.scm | 168 - module/slib/macrotst.scm | 54 - module/slib/macscheme.init | 276 - module/slib/macwork.scm | 126 - module/slib/makcrc.scm | 96 - module/slib/mbe.scm | 443 - module/slib/minimize.scm | 114 - module/slib/minimize.txi | 48 - module/slib/mitcomp.pat | 1466 ---- module/slib/mitscheme.init | 283 - module/slib/mklibcat.scm | 198 - module/slib/modular.scm | 158 - module/slib/mulapply.scm | 28 - module/slib/mularg.scm | 12 - module/slib/mwdenote.scm | 289 - module/slib/mwexpand.scm | 565 -- module/slib/mwsynrul.scm | 343 - module/slib/nclients.scm | 385 - module/slib/nclients.txi | 103 - module/slib/obj2str.scm | 63 - module/slib/obj2str.txi | 9 - module/slib/objdoc.txi | 238 - module/slib/object.scm | 97 - module/slib/paramlst.scm | 141 - module/slib/plottest.scm | 47 - module/slib/pnm.scm | 213 - module/slib/pp.scm | 15 - module/slib/ppfile.scm | 70 - module/slib/prec.scm | 448 - module/slib/printf.scm | 584 -- module/slib/priorque.scm | 136 - module/slib/process.scm | 68 - module/slib/promise.scm | 29 - module/slib/pscheme.init | 206 - module/slib/psxtime.scm | 155 - module/slib/qp.scm | 149 - module/slib/queue.scm | 72 - module/slib/r4rsyn.scm | 542 -- module/slib/randinex.scm | 127 - module/slib/randinex.txi | 56 - module/slib/random.scm | 139 - module/slib/random.txi | 55 - module/slib/ratize.scm | 17 - module/slib/rdms.scm | 629 -- module/slib/recobj.scm | 55 - module/slib/record.scm | 228 - module/slib/repl.scm | 92 - module/slib/report.scm | 116 - module/slib/require.scm | 274 - module/slib/root.scm | 217 - module/slib/sc2.scm | 66 - module/slib/sc4opt.scm | 53 - module/slib/sc4sc3.scm | 35 - module/slib/scaexpp.scm | 2956 ------- module/slib/scaglob.scm | 32 - module/slib/scainit.scm | 104 - module/slib/scamacr.scm | 181 - module/slib/scanf.scm | 350 - module/slib/scaoutp.scm | 93 - module/slib/scheme2c.init | 304 - module/slib/scheme48.init | 282 - module/slib/schmooz.scm | 628 -- module/slib/schmooz.texi | 104 - module/slib/scm.init | 6 - module/slib/scmacro.scm | 119 - module/slib/scmactst.scm | 160 - module/slib/scsh.init | 284 - module/slib/selfset.scm | 28 - module/slib/sierpinski.scm | 71 - module/slib/simetrix.scm | 246 - module/slib/slib.info | 12187 --------------------------- module/slib/slib.spec | 85 - module/slib/slib.texi | 11142 ------------------------ module/slib/sort.scm | 154 - module/slib/soundex.scm | 82 - module/slib/stdio.scm | 8 - module/slib/strcase.scm | 66 - module/slib/strport.scm | 51 - module/slib/strsrch.scm | 146 - module/slib/struct.scm | 165 - module/slib/structst.scm | 37 - module/slib/structure.scm | 80 - module/slib/syncase.sh | 146 - module/slib/synchk.scm | 104 - module/slib/synclo.scm | 748 -- module/slib/synrul.scm | 327 - module/slib/t3.init | 437 - module/slib/tek40.scm | 92 - module/slib/tek41.scm | 147 - module/slib/timezone.scm | 264 - module/slib/trace.scm | 254 - module/slib/tree.scm | 62 - module/slib/trnscrpt.scm | 76 - module/slib/tsort.scm | 46 - module/slib/tzfile.scm | 138 - module/slib/umbscheme.init | 273 - module/slib/uri.scm | 318 - module/slib/uri.txi | 94 - module/slib/values.scm | 27 - module/slib/version.txi | 2 - module/slib/vscm.init | 389 - module/slib/withfile.scm | 82 - module/slib/wttest.scm | 134 - module/slib/wttree.scm | 790 -- module/slib/yasyn.scm | 201 - module/system/Makefile.am | 2 +- module/system/base/Makefile.am | 4 +- module/system/il/Makefile.am | 3 +- module/system/repl/Makefile.am | 4 +- module/system/vm/Makefile.am | 1 - 176 files changed, 7 insertions(+), 62200 deletions(-) delete mode 100644 module/guile/slib.scm delete mode 100644 module/slib/.cvsignore delete mode 100644 module/slib/ANNOUNCE delete mode 100644 module/slib/Bev2slib.scm delete mode 100644 module/slib/ChangeLog delete mode 100644 module/slib/DrScheme.init delete mode 100644 module/slib/FAQ delete mode 100644 module/slib/Makefile delete mode 100644 module/slib/README delete mode 100644 module/slib/RScheme.init delete mode 100644 module/slib/STk.init delete mode 100644 module/slib/Template.scm delete mode 100644 module/slib/alist.scm delete mode 100644 module/slib/alistab.scm delete mode 100644 module/slib/array.scm delete mode 100644 module/slib/arraymap.scm delete mode 100644 module/slib/batch.scm delete mode 100644 module/slib/bigloo.init delete mode 100644 module/slib/break.scm delete mode 100644 module/slib/byte.scm delete mode 100644 module/slib/chap.scm delete mode 100644 module/slib/charplot.scm delete mode 100644 module/slib/chez.init delete mode 100644 module/slib/cltime.scm delete mode 100644 module/slib/coerce.scm delete mode 100644 module/slib/coerce.txi delete mode 100644 module/slib/collect.scm delete mode 100644 module/slib/comlist.scm delete mode 100644 module/slib/comparse.scm delete mode 100644 module/slib/cring.scm delete mode 100644 module/slib/db2html.scm delete mode 100644 module/slib/db2html.txi delete mode 100644 module/slib/dbrowse.scm delete mode 100644 module/slib/dbutil.scm delete mode 100644 module/slib/debug.scm delete mode 100644 module/slib/defmacex.scm delete mode 100644 module/slib/determ.scm delete mode 100644 module/slib/dwindtst.scm delete mode 100644 module/slib/dynamic.scm delete mode 100644 module/slib/dynwind.scm delete mode 100644 module/slib/elk.init delete mode 100644 module/slib/eval.scm delete mode 100644 module/slib/factor.scm delete mode 100644 module/slib/factor.txi delete mode 100644 module/slib/fft.scm delete mode 100644 module/slib/fluidlet.scm delete mode 100644 module/slib/fmtdoc.txi delete mode 100644 module/slib/format.scm delete mode 100644 module/slib/formatst.scm delete mode 100644 module/slib/gambit.init delete mode 100644 module/slib/genwrite.scm delete mode 100644 module/slib/getopt.scm delete mode 100644 module/slib/getparam.scm delete mode 100644 module/slib/glob.scm delete mode 100644 module/slib/guile.init delete mode 100644 module/slib/hash.scm delete mode 100644 module/slib/hashtab.scm delete mode 100644 module/slib/htmlform.scm delete mode 100644 module/slib/htmlform.txi delete mode 100644 module/slib/http-cgi.scm delete mode 100644 module/slib/http-cgi.txi delete mode 100644 module/slib/lineio.scm delete mode 100644 module/slib/lineio.txi delete mode 100644 module/slib/logical.scm delete mode 100644 module/slib/macrotst.scm delete mode 100644 module/slib/macscheme.init delete mode 100644 module/slib/macwork.scm delete mode 100644 module/slib/makcrc.scm delete mode 100644 module/slib/mbe.scm delete mode 100644 module/slib/minimize.scm delete mode 100644 module/slib/minimize.txi delete mode 100644 module/slib/mitcomp.pat delete mode 100644 module/slib/mitscheme.init delete mode 100644 module/slib/mklibcat.scm delete mode 100644 module/slib/modular.scm delete mode 100644 module/slib/mulapply.scm delete mode 100644 module/slib/mularg.scm delete mode 100644 module/slib/mwdenote.scm delete mode 100644 module/slib/mwexpand.scm delete mode 100644 module/slib/mwsynrul.scm delete mode 100644 module/slib/nclients.scm delete mode 100644 module/slib/nclients.txi delete mode 100644 module/slib/obj2str.scm delete mode 100644 module/slib/obj2str.txi delete mode 100644 module/slib/objdoc.txi delete mode 100644 module/slib/object.scm delete mode 100644 module/slib/paramlst.scm delete mode 100644 module/slib/plottest.scm delete mode 100644 module/slib/pnm.scm delete mode 100644 module/slib/pp.scm delete mode 100644 module/slib/ppfile.scm delete mode 100644 module/slib/prec.scm delete mode 100644 module/slib/printf.scm delete mode 100644 module/slib/priorque.scm delete mode 100644 module/slib/process.scm delete mode 100644 module/slib/promise.scm delete mode 100644 module/slib/pscheme.init delete mode 100644 module/slib/psxtime.scm delete mode 100644 module/slib/qp.scm delete mode 100644 module/slib/queue.scm delete mode 100644 module/slib/r4rsyn.scm delete mode 100644 module/slib/randinex.scm delete mode 100644 module/slib/randinex.txi delete mode 100644 module/slib/random.scm delete mode 100644 module/slib/random.txi delete mode 100644 module/slib/ratize.scm delete mode 100644 module/slib/rdms.scm delete mode 100644 module/slib/recobj.scm delete mode 100644 module/slib/record.scm delete mode 100644 module/slib/repl.scm delete mode 100644 module/slib/report.scm delete mode 100644 module/slib/require.scm delete mode 100644 module/slib/root.scm delete mode 100644 module/slib/sc2.scm delete mode 100644 module/slib/sc4opt.scm delete mode 100644 module/slib/sc4sc3.scm delete mode 100644 module/slib/scaexpp.scm delete mode 100644 module/slib/scaglob.scm delete mode 100644 module/slib/scainit.scm delete mode 100644 module/slib/scamacr.scm delete mode 100644 module/slib/scanf.scm delete mode 100644 module/slib/scaoutp.scm delete mode 100644 module/slib/scheme2c.init delete mode 100644 module/slib/scheme48.init delete mode 100644 module/slib/schmooz.scm delete mode 100644 module/slib/schmooz.texi delete mode 100644 module/slib/scm.init delete mode 100644 module/slib/scmacro.scm delete mode 100644 module/slib/scmactst.scm delete mode 100644 module/slib/scsh.init delete mode 100644 module/slib/selfset.scm delete mode 100644 module/slib/sierpinski.scm delete mode 100644 module/slib/simetrix.scm delete mode 100644 module/slib/slib.info delete mode 100644 module/slib/slib.spec delete mode 100644 module/slib/slib.texi delete mode 100644 module/slib/sort.scm delete mode 100644 module/slib/soundex.scm delete mode 100644 module/slib/stdio.scm delete mode 100644 module/slib/strcase.scm delete mode 100644 module/slib/strport.scm delete mode 100644 module/slib/strsrch.scm delete mode 100644 module/slib/struct.scm delete mode 100644 module/slib/structst.scm delete mode 100644 module/slib/structure.scm delete mode 100644 module/slib/syncase.sh delete mode 100644 module/slib/synchk.scm delete mode 100644 module/slib/synclo.scm delete mode 100644 module/slib/synrul.scm delete mode 100644 module/slib/t3.init delete mode 100644 module/slib/tek40.scm delete mode 100644 module/slib/tek41.scm delete mode 100644 module/slib/timezone.scm delete mode 100644 module/slib/trace.scm delete mode 100644 module/slib/tree.scm delete mode 100644 module/slib/trnscrpt.scm delete mode 100644 module/slib/tsort.scm delete mode 100644 module/slib/tzfile.scm delete mode 100644 module/slib/umbscheme.init delete mode 100644 module/slib/uri.scm delete mode 100644 module/slib/uri.txi delete mode 100644 module/slib/values.scm delete mode 100644 module/slib/version.txi delete mode 100644 module/slib/vscm.init delete mode 100644 module/slib/withfile.scm delete mode 100644 module/slib/wttest.scm delete mode 100644 module/slib/wttree.scm delete mode 100644 module/slib/yasyn.scm diff --git a/Makefile.am b/Makefile.am index e9069d36d..1090cea7e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,4 +1,5 @@ SUBDIRS = src doc testsuite +DIST_SUBDIRS = src module doc testsuite # FIXME: The `module' directory is removed from `SUBDIRS' until it can # actually be built. diff --git a/module/Makefile.am b/module/Makefile.am index 006ba0c4b..06fde9ae2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -1,15 +1 @@ -SUBDIRS = system - -DISTDIRS = $(srcdir)/system $(srcdir)/language $(srcdir)/guile $(srcdir)/slib -EXCLUDES = --exclude=CVS --exclude=*.go --exclude=*~ - -all: slibcat - -clean: - rm -f slibcat slib/*.go - -slibcat: - guile -s $(top_srcdir)/src/guilec slib/*.scm - -dist-hook: - $(TAR) cf - $(EXCLUDES) $(DISTDIRS) | (cd $(distdir); $(TAR) xf -) +SUBDIRS = system language diff --git a/module/guile/slib.scm b/module/guile/slib.scm deleted file mode 100644 index d07044197..000000000 --- a/module/guile/slib.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Guile SLIB interface - -;; Copyright (C) 2001 Free Software Foundation, Inc. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(define-module (guile slib) - :use-module (system vm core)) - -(define (slib:load file) - (let ((comp (string-append file ".go"))) - (cond ((file-exists? comp) (load-compiled comp)) - ((file-exists? file) (load file)) - (else (load (string-append file ".scm"))))) - (module-export! (current-module) - (delq! '%module-public-interface - (hash-fold (lambda (k v d) (cons k d)) '() - (module-obarray (current-module)))))) - -(let ((file (%search-load-path "slib/guile.init"))) - (if file - (slib:load file) - (error "Could not find slib/guile.init in" %load-path))) - -(define-public require require:require) diff --git a/module/language/scheme/Makefile.am b/module/language/scheme/Makefile.am index 2312a2acd..2762c9616 100644 --- a/module/language/scheme/Makefile.am +++ b/module/language/scheme/Makefile.am @@ -1,16 +1,11 @@ -SOURCES = +SOURCES = translate.scm spec.scm ## FIXME: There's a bug showing up when compiling `translate.scm'. -## -## `spec.scm' cannot be compiled because it uses the `define-language' -## macro which introduces an unregular object, namely the first-class -## `' procedure. GOBJECTS = $(SOURCES:%.scm=%.go) vmdir = $(guiledir)/language/scheme vm_DATA = $(SOURCES) $(GOBJECTS) CLEANFILES = $(GOBJECTS) -MAINTAINERCLEANFILES = Makefile.in SUFFIXES = .scm .go %.go: %.scm diff --git a/module/slib/.cvsignore b/module/slib/.cvsignore deleted file mode 100644 index e796b66a8..000000000 --- a/module/slib/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -*.go diff --git a/module/slib/ANNOUNCE b/module/slib/ANNOUNCE deleted file mode 100644 index d8a00b585..000000000 --- a/module/slib/ANNOUNCE +++ /dev/null @@ -1,171 +0,0 @@ -This message announces the availability of Scheme Library release slib2d1. - -New in slib2d1: - - + Linux RPM distribution. - - + Automated generation of HTTP/HTML static and (multi-client) - dynamically editable tables from relational databases. - (HTTP server demo at http://www.foxkid.net:8143/tla/). - - + Reference implementation of Metric Interchange Format: - "Representation of numerical values and SI units in character strings - for information interchanges" - http://swissnet.ai.mit.edu/~jaffer/MIXF.html - - * Makefile (rpm): Added to dist target. - (mfiles): Added slib.spec. - * slib.spec: Added spec file to generate a .rpm file. - Largely based on that of Dr. Robert J. Meier - - * Makefile (docfiles): Added all the *.txi. - * db2html.scm (HTML editing tables): Replaced "record" with "row". - * http-cgi.scm (query-alist->parameter-list): Null string --> #f. - * coerce.scm (type-of): Removed 'null; broke (coerce '() 'string). - * htmlform.scm (html:meta, html:http-equiv): Added. - * htmlform.scm (html:meta-refresh): Added. - * http-cgi.scm (query-alist->parameter-list): Only separate words - for nary parameters. - * getparam.scm (getopt->parameter-list): Accomodate positional - arguments, both ends. - (getopt->parameter-list, getopt->arglist): Take optional - description strings. - * db2html.scm (command:make-editable-table): Added optional - arguments passed to command:modify-table. - (command:modify-table): Added null-keys argument; removed pkl. - * http-cgi.scm (http:forwarding-page): Added. - * htmlform.scm (html:text-area): fixed. - * http-cgi.scm (coerce->list): Added. - * paramlst.scm (check-arities): Generate warning for wrong arity. - * db2html.scm (command:make-editable-table): Deduce arities. - * comlist.scm (comlist:list-of??): Added. - * coerce.scm (coerce, type-of): Extracted from comlist.scm. - * uri.scm (uri:path->keys): Takes list of type-symbols. - * simetrix.scm (SI:unit-infos): bit is "bit" (not b). - * uri.scm (uri:decode-path, uri:path->keys): Now take path-list - instead of path. Fixes bug when '/' was in URI path. - * http-cgi.scm (make-query-alist-command-server): Renamed from - make-uriencoded-command-server; takes query-alist instead of - query-string. Diagnostics can use query-alist without recreating. - * db2html.scm (html:linked-row-converter): If a field has a - foreign-key of "*catalog-data*", then link to foreign table. - (catalog->html, table->linked-html): Put caption at BOTTOM. - * htmlform.scm (command->p-specs): Renamed from command->html - because it has changed so much. No longer does mapper argument. - * db2html.scm (command:make-editable-table): Returns editing-row - procedure. - * htmlform.scm (html:select, html:buttons, form:element, - form:delimited): value-list and visibles arguments combined. - * dbutil.scm (get-foreign-choices): extracted from command->html. - (make-defaulter): Added. - * strcase.scm (symbol-append): Added. - * http-cgi.scm (make-uriencoded-command-server): Only apply comval - if arglist worked. - * htmlform.scm (command->html): Big change; returns list of - results of application of (new) MAPPER argument. - (form:delimited, form:tabled): Added MAPPER procedures. - * db2html.scm (html:editable-row-converter): Check for - edit-converter being #f. - (command:make-editable-table): *keys*, *row-hash* NOT optional. - * htmlform.scm (form:element): Extracted from html:generate-form. - * db2html.scm (html:editable-row-converter): Added. - (command:modify-table): Handle case all fields are primary keys. - * db2html.scm (command:modify-table, command:make-editable-table): - (HTML editing tables): Added. - * htmlform.scm (form:submit): Enhanced. - * uri.scm (uri:decode-authority, make-uri): en/decode userinfo. - (uri:make-path): Added. - (read-anchor-string): Removed; just use paths for combined keys. - * slib.texi (Lists as sets): Examples had incorrect order in - returned lists. - * uri.scm (html:base, html:isindex): Added. - (uri->tree): Optional base-tree argument added for relative URI. - Brought into full conformance with RFC 2396 test cases. - * uri.scm (html:anchor, html:link uri->tree make-uri): Added. - (uri:split-fields, uri:decode-query): Moved and renamed from - http-cgi.scm. - * htmlform.scm (form:image): Added. - * uri.scm: Added collected URI functions from "http-cgi.scm" and - "db2html.scm". - * makcrc.scm (make-port-crc): Added CRC-16 default. Can now take - just generator argument. - * db2html.scm (html:linked-row-converter, table->linked-html, - table->linked-page, db->html-files, db->html-directory): more - evocative names. - (html:catalog-row-converter): Stripped down version for catalog. - * pp.scm (pretty-print->string): Added. - (pp:pretty-print): Use (output-port-width port) for width. - * genwrite.scm (genwrite:newline-str): abstracted. - * htmlform.scm (html:pre): Improved HTML formatting. - * http-cgi.scm (query-alist->parameter-list): Made robust for - unexpected option-names; and generates warning. - * db2html.scm: Fixed HTML per http://validator.w3.org/check. - * simetrix.scm (SI:conversion-factor): Negative return codes. - * simetrix.scm (SI:unit-infos): Added katal. Replaced bel (B) - with decibel (dB). - (SI:prefix-exponents): Added [IEC 60027-2] binary prefixes. - (SI:unit-infos): Added bit and byte (B). - * simetrix.scm (SI:unit-infos): Updated eV and u from CODATA-1998. - (SI:solidus): Abstracted parse functions. - * simetrix.scm: SI Metric Interchange Format for Scheme Added. - * scanf.scm (stdio:scan-and-set read-ui): Fixed dependence on LET - evaluation order. - * schmooz.texi: Split out from slib.texi. - * printf.scm (stdio:parse-float): Adjust so %e format prints an - exponent of zero for 0.0 - * dbutil.scm (dbutil:list-table-definition): Added. - * db2html.scm (html:caption): Split out from html:table. - * rdms.scm (sync-database): Added. - * pnm.scm (pnm:array-write): PGMs were always being written with - 15 for maxval. - * http-cgi.scm (make-urlencoded-command-server): Uses the value of - *suggest* if *command* is not in the query-string; if neither uses - literal *default*. - * htmlform.scm (html:form html:hidden html:checkbox html:text - html:text-area html:select html:buttons form:submit form:reset): - Procedures documented. No longer builds in
tags. - * htmlform.scm (html:blank): Added. - (html:plain): Returns non-break-space for html:blank. - (html:select html:buttons command->html html:generate-form): Added - support for VISIBLE-NAME field for foreign-key domains. - * debug.scm (for-each-top-level-definition-in-file): define-syntax - is a top-level-definition too. - * makcrc.scm (make-port-crc): Converted to use read-byte. - * htmlform.scm (html:generate-form): was ignoring method. - -From Ben Goetter - * pscheme.init: Revised. - -From Lars Arvestad - * gambit.init (*features*): Gambit 3.0 provides - call-with-input-string and call-with-output-string. - -SLIB is a portable Scheme library providing compatibiliy and utility -functions for all standard Scheme implementations. - -SLIB includes initialization files for Bigloo, Chez, DrScheme, ELK, -GAMBIT, MacScheme, MITScheme, PocketScheme, RScheme Scheme->C, -Scheme48, SCM, SCSH, T3.1, UMB-Scheme, and VSCM. - -Documentation includes a manifest, installation instructions, and -coding guidelines for the library. Documentation of each library -package is supplied. SLIB Documentation is online at: - - http://swissnet.ai.mit.edu/~jaffer/SLIB.html - -SLIB is available from: - http://swissnet.ai.mit.edu/ftpdir/scm/slib2d1.zip - http://swissnet.ai.mit.edu/ftpdir/scm/slib-2d1-1.noarch.rpm - swissnet.ai.mit.edu:/pub/scm/slib2d1.zip - swissnet.ai.mit.edu:/pub/scm/slib-2d1-1.noarch.rpm - -SLIB-PSD is a portable debugger for Scheme (requires emacs editor): - http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.zip - swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.zip - -SCHELOG is an embedding of Prolog in Scheme+SLIB: - http://www.cs.rice.edu/CS/PLT/packages/schelog/ - -Programs for printing and viewing TexInfo documentation (which SLIB -has) come with GNU Emacs or can be obtained via ftp from: - ftp.gnu.org:pub/gnu/texinfo/texinfo-4.0.tar.gz diff --git a/module/slib/Bev2slib.scm b/module/slib/Bev2slib.scm deleted file mode 100644 index 24a7c68f6..000000000 --- a/module/slib/Bev2slib.scm +++ /dev/null @@ -1,94 +0,0 @@ -;;;; "Bev2slib.scm" Build SLIB catalogs for Stephen Bevan's libraries. -;Copyright (C) 1998 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;; Put this file into the implementation-vicinity directory for your -;;; scheme implementation. - -;;; Add the line -;;; (load (in-vicinity (implementation-vicinity) "Bev2slib.scm")) -;;; to "mkimpcat.scm" - -;;; Delete "slibcat" in your implementation-vicinity. - -;;; Bind `Bevan-dir' to the directory containing directories "bawk", -;;; "mawk", "pathname", etc. Bev2slib.scm will put entries into the -;;; catalog only for those directories and files which exist. - -(let ((Bevan-dir (in-vicinity (library-vicinity) "../"));"/usr/local/lib/Bevan/" - (catname "sitecat")) - (call-with-output-file (in-vicinity (implementation-vicinity) catname) - (lambda (op) - (define (display* . args) - (for-each (lambda (arg) (display arg op)) args) - (newline op)) - (define (add-alias from to) - (display " " op) - (write (cons from to) op) - (newline op)) - - (begin - (display* ";\"" catname "\" Site-specific SLIB catalog for " - (scheme-implementation-type) (scheme-implementation-version) - ". -*-scheme-*-") - (display* ";") - (display* "; DO NOT EDIT THIS FILE") - (display* "; it is automagically generated by \"Bev2slib.scm\"") - (newline op) - ) - - ;; Output association lists to file "sitecat" - - (for-each - (lambda (dir) - (let* ((vic (in-vicinity Bevan-dir (string-append dir "/"))) - (map-file (in-vicinity vic (string-append dir ".map")))) - - (display* ";;; from " map-file) - (display* "(") - - (and - (file-exists? map-file) - (call-with-input-file map-file - (lambda (ip) - (define files '()) - (do ((feature (read ip) (read ip))) - ((eof-object? feature)) - (let* ((type (read ip)) - (file (read ip)) - (fsym (string->symbol (string-append "Req::" file)))) - (and (not (assq fsym files)) - (set! files (cons (cons fsym file) files))) - (add-alias feature fsym))) - (for-each - (lambda (pr) (add-alias (car pr) (in-vicinity vic (cdr pr)))) - files) - ))) - - (display* ")"))) - - '("char-set" "conc-string" "string" "string-03" - "avl-tree" "avl-trie" - "bawk" "mawk" "pathname")) - - (begin - (display* "(") - (add-alias 'btree (in-vicinity Bevan-dir "bawk/btree")) - (add-alias 'read-line 'line-i/o) - (display* ")") - )))) diff --git a/module/slib/ChangeLog b/module/slib/ChangeLog deleted file mode 100644 index 9c71f1f47..000000000 --- a/module/slib/ChangeLog +++ /dev/null @@ -1,2604 +0,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 - - * charplot.scm (charplot:number->string): printf %g gets rid of - microscopic fractions. - - * printf.scm (%g): Make precision threshold work for both - fractions and integers. - -1999-12-03 Aubrey Jaffer - - * nclients.scm (browse-url-netscape): Try running netscape in - background. - -1999-11-14 Aubrey Jaffer - - * batch.scm (write-batch-line): Added slib:warn. - -1999-11-01 Aubrey Jaffer - - * paramlst.scm (check-parameters): Improved warning. - -1999-10-31 Aubrey Jaffer - - * batch.scm (batch:command): Renamed from batch:system. - (batch:try-command): Renamed from batch:try-system. - (batch:try-chopped-command): Added. - (batch:apply-chop-to-fit): Removed. - -1999-09-29 Radey Shouman - - * glob.scm (replace-suffix): Now works. - -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 - - * require.scm (*SLIB-VERSION*): Bumped from 2c5 to 2c6. - -1999-07-08 Aubrey Jaffer - - * format.scm (format:string-capitalize-first): Renamed from - string-capitalize-first. - (format:list-head): Renamed from list-head. - (string-index): Removed. - -1999-06-07 Radey Shouman - - * printf.scm (stdio:parse-float): Now handles strings representing - complex numbers in polar form. - - (stdio:parse-float): Now parses non-real numbers written in - rectangular form. - - (stdio:iprintf): Inexact formats work on non-real numbers assuming - NUMBER->STRING outputs a rectangular format. - - Inexact formats given a string or symbol rather than a number - output "???" if the string cannot be parsed as an inexact number. - -1999-06-06 Aubrey Jaffer - - * fft.scm (fft fft-1): Added. - -1999-06-05 Radey Shouman - - * glob.scm (glob:substitute??): (glob:substitute-ci??): Now accept - a procedure or string as template argument, for more general - transformations. - -1999-05-28 Gary T. Leavens - - * chez.init: Updated for Chez Scheme 6.0a. - - * bigloo.init: Added. - -1999-05-18 Aubrey Jaffer - - * printf.scm (stdio:iprintf): Extra arguments are *not* a bug. - -1999-05-08 Aubrey Jaffer - - * lineio.scm (read-line!): fixed to eat trailing newline when line - length equals string length. - -1999-05-08 Ben Goetter - - * pscheme.init: String-ports added for version Pscheme 0.3.6. - -1999-05-07 - - * charplot.scm (plot-function): Added. - (charplot:plot!): Now will accept array argument. - -1999-05-02 Jim Blandy - - * format.scm (format:format): If the first argument is the format - string, stick a #f on the front of it, so it is now a valid CL - format argument list. This is easier than changing everyplace - else (like the error formatter) that expects it to be in CL form. - The other clause which explicitly tests for this case is now dead - code; remove it. - (format:format-work): Allow `@' and `:' in either order, as per - modern CL behavior. - (format:num->cardinal): Don't assume that an elseless if returns - '() when the condition is false. - -1999-04-22 Radey Shouman - - * root.scm (secant:find-root): Replaced hack to decide on - accepting regula-falsi step with a modified regula-falsi in which - the weight of an "old" function value is repeatedly decreased each - time it is retained. - -1999-04-13 Radey Shouman - - * root.scm (secant:find-root): Now checks that a step is actually - of nonzero length, otherwise small tolerances lead to not - stopping. Tuned for the case that one starting point is much - closer to the root than the other. - -1999-04-08 Ben Goetter - - * pscheme.init: updated with defmacro for version 0.3.3. - -1999-04-04 Aubrey Jaffer - - * lineio.scm: Fixed @args command in documentation-comment. - -1999-03-27 Aubrey Jaffer - - * strsrch.scm (find-string-from-port?): Fixed so procedure - argument is called at most once per character. - -1999-03-11 Radey Shouman - - * fluidlet.scm: Added (require 'common-list-functions), for - MAKE-LIST. - -1999-03-08 Aubrey Jaffer - - * RScheme.init, STk.init, Template.scm, chez.init, elk.init, - gambit.init, macscheme.init, mitscheme.init, pscheme.init, - scheme2c.init, scheme48.init, scsh.init, t3.init, vscm.init: Added - scheme-implementation-home-page definition - -1999-03-04 radey - - * root.scm (secant:find-bracketed-root): Added, requires (f x0) - and (f x1) to have opposite signs. - -1999-03-03 Radey Shouman - - * printf.scm (stdio:printf): Tweaks to %k format so that the - precision indicates the number of significant digits, as in %g - format. - -1999-03-02 Radey Shouman - - * printf.scm (stdio:printf): %k format now uses %f instead of %g - to format the scaled number. - - * root.scm (secant:find-root): Added. - -1999-02-25 Radey Shouman - - * printf.scm (stdio:iprintf): Fixed bug in %f format, - (printf "%.1f" 0.001) printed "0", now prints "0.0" - -1999-02-12 Hakan L. Younes - - * batch.scm, slib.texi: amiga-gcc port. - -1999-02-10 Radey Shouman - - * printf.scm (stdio:iprintf): K format now prints no prefix if - exponent is beyond the range of the specified prefixes. - - (stdio:iprintf): Added and corrected SI prefixes, ref - http://physics.nist.gov/cuu/Units/prefixes.html . - - (stdio:iprintf): Added numerical format specifiers %K and %k, - which format like %g, except that an SI prefix is output after the - number, which is scaled accordingly. %K outputs a space between - number and prefix, %k does not. It would be good to allow %f and - %e like formatting, but it's not clear how to fit this into the - format string syntax. - -1999-02-09 Aubrey Jaffer - - * rdms.scm (domains:init-data): added number domain. - -1999-01-30 Matthew Flatt - - * mbe.scm (hyg:untag-quasiquote): Added to fix quasiquote in output. - -1999-01-30 Dorai Sitaram - - * mbe.scm (mbe:ellipsis-sub-envs, mbe:append-map): Modified to fix - multiple ellipses problem. - -1999-01-26 Erick Gallesio - - * STk.init: The actual file. - -1999-01-25 Aubrey Jaffer - - * RScheme.init: added; content is from - http://www.rscheme.org/rs/pg1/RScheme.scm - -1999-01-24 Aubrey Jaffer - - * STk.init: added; content is from - http://kaolin.unice.fr/STk/FAQ/FAQ-1.html#ss1.9 - -1999-01-23 Aubrey Jaffer - - * alistab.scm (open-base): Check file exists before opening it. - -1999-01-21 Aubrey Jaffer - - * htmlform.scm (html:start-page): Extra arguments printed in HEAD - (for META tags). - -1999-01-20 Aubrey Jaffer - - * htmlform.scm (make-atval make-plain): use object->string for - non-atomic arguments. - -1999-01-19 Radey Shouman - - * printf.scm (stdio:iprintf): Now reports wrong number of - arguments instead of silently ignoring extra arguments or taking - the CAR of the empty list. - -Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer - - * require.scm (*SLIB-VERSION*): Bumped from 2c4 to 2c5. - -1999-01-12 Aubrey Jaffer - - * mitscheme.init (char-code-limit): Added. Builtin - char-code-limit is 65536 (NOT!) in MITScheme Version 8.0. - -1999-01-11 Aubrey Jaffer - - * batch.scm (batch:apply-chop-to-fit): fixed off-by-1 error. - -1999-01-10 Aubrey Jaffer - - * randinex.scm: moved (schmooz) documentation here from scm.texi. - (random:uniform1): Renamed from random:uniform. - (random:uniform): Added (takes optional state argument). - (random:normal): Made reentrant. - - * random.scm: moved (schmooz) documentation here from scm.texi. - -1999-01-09 Aubrey Jaffer - - * random.scm (seed->random-state): added. - -1999-01-08 Aubrey Jaffer - - * mitscheme.init (object->limited-string): Added. - - * random.scm (random:random): Fixed embarrassingly stupid bug. - -1999-01-07 Aubrey Jaffer - - * alistab.scm (supported-key-type?): number now allowed. - -1998-12-22 Radey Shouman - - * printf.scm (stdio:round-string): Makes sure result has at least - STRIP-0S characters after the implied decimal point if STRIP-0S is - not false. Fixes bug associated with engineering notation in SCM. - -1998-12-18 Aubrey Jaffer - - * schmooz.scm (schmooz): Converted from replace-suffix to - filename:substitute??. - -1998-12-16 Radey Shouman - - * glob.scm (glob:make-substituter): Made to handle cases where - PATTERN and TEMPLATE have different numbers of literal sections. - - * glob.scm (glob:pattern->tokens): (glob:make-matcher): - (glob:make-substituter): Fixed to accept null strings as literals - to match, for REPLACE-SUFFIX. There is no way to write a glob - pattern that produces such a token, should there be? - -1998-12-15 Radey Shouman - - * glob.scm (glob:substitute??) renamed from glob:transform?? - (filename:substitute??) identical to glob:substitute?? - -1998-12-14 Radey Shouman - - * glob.scm (glob:pattern->tokens): Separated from - GLOB:MAKE-MATCHER. - (glob:make-transformer): - (glob:transform??): - (glob:transform-ci??): Added. - (replace-suffix): Rewritten using GLOB:TRANSFORM?? - -1998-12-09 Aubrey Jaffer - - * yasyn.scm: Restored to SLIB. yasos.scm removed. - * object.scm: Restored to SLIB - * recobj.scm: Restored to SLIB - -1998-12-08 Aubrey Jaffer - - * slib.texi (Copyrights): Added HTML anchor for Copying information. - (Installation): Added HTML anchor for Installation instructions. - -1998-12-02 Aubrey Jaffer - - * fluidlet.scm (fluid-let): Rewritten as defmacro. - -1998-11-30 Radey Shouman - - * fluidlet.scm (fluid-let): Changed macro definition so that it - doesn't depend on being able to combine input from two different - ellipsis patterns. Now produces a nice expansion with - macro-by-example so that one can see exactly what goes wrong. - -1998-11-29 Aubrey Jaffer - - * htmlform.scm (table->html): Table conversion functions added. - -1998-11-27 Aubrey Jaffer - - * nclients.scm (glob-pattern?): Added. - -1998-11-24 Aubrey Jaffer - - * htmlform.scm (html:href-heading): simplified. - -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; - html: functions now all output HTML. - - * nclients.scm (user-email-address): Ported to W95 and WNT. - (make-directory): added. - - * dbrowse.scm (browse:display-table): Column-foreigns restored. - - * htmlform.scm (html:atval html:plain): Now accept numbers. - (html:pre): Added. - (html:start-page html:end-page): Updated to HTML 3.2. HTML header - added. - - * rdms.scm (make-relational-system): column-foreign-list split - into column-foreign-check-list and column-foreign-list. - -1998-11-12 Aubrey Jaffer - - * lineio.scm (display-file): added. Schmoozed docs. - -1998-11-12 Radey Shouman - - * schmooz.scm (schmooz-top): No longer emits @defun lines for - definitions not separated by blank lines unless they have - associated @body comment lines. - -1998-11-11 Radey Shouman - - * fluidlet.scm (fluid-let): Redone to restore variable values even - if a continuation captured in the body is invoked. Now agrees - with MIT Scheme documentation. - -1998-11-11 Aubrey Jaffer - - * nclients.scm: Added net-clients. - - * require.scm (vicinity:suffix?): Abstracted from - program-vicinity. - -1998-11-04 Aubrey Jaffer - - * comlist.scm (remove-duplicates): added. - (adjoin): memq -> memv. - -Tue Nov 3 17:47:32 EST 1998 Aubrey Jaffer - - * require.scm (*SLIB-VERSION*): Bumped from 2c3 to 2c4. - -1998-10-24 Aubrey Jaffer - - * cring.scm: Added procedures to create and manipulate rulesets. - - * cring.scm (cring:db): Distributing / over + led to infinite - loops. Now only distribute *. - -1998-10-19 amu@mit.edu - - * timezone.scm (tzfile:vicinity): Linux RH 5.x moved zoneinfo to - /usr/share and didn't bother to leave a symlink behind. This - caused ctime to print out things in GMT, instead of using the - local time. - -1998-10-01 Aubrey Jaffer - - * factor.scm: Moved documentation to schmooz format. - (prime:prime< prime:prime>): written. - (prime:prngs): added. - (Solovay-Strassen??): No longer tries `1'. - (prime:products): Added list of prime products smaller than - most-positive-fixnum. - (prime:sieve): added to test for primes smaller than largest prime - in prime:products. - (prime:factor): wrapper rewritten. Code cleaned up. - - * primes.scm: removed. - -1998-09-29 Aubrey Jaffer - - * paramlst.scm (check-parameters): Now generates slib:warn when - parameter is wrong type. - - * debug.scm (for-each-top-level-definition-in-file): Now discards - `magic-number' first line of files when first character is `#'. - - * batch.scm (batch:port parms): enabled warning. - -1998-09-28 Aubrey Jaffer - - * scheme2c.init scsh.init t3.init chez.init, vscm.init, - scheme48.init, mitscheme.init, macscheme.init, gambit.init, - elk.init, Template.scm: Placed in public domain to make - distributing modified versions easier. - - * schmooz.scm, htmlform.scm, admin.scm, glob.scm, ChangeLog: - Cleaned a bit. - -1998-09-28 Aubrey Jaffer - - * slib.texi (most-positive-fixnum): fixed description. - -1998-09-22 Ortwin Gasper - - * random.scm (random:random): Removed one-parameter call to - logand. - -1998-09-22 Radey Shouman - - * schmooz.scm: Changed all references to #\nl to #\newline. - Removed all references to #\cr. Trailing whitespace no longer - prevents issuing a defunx for an additional definition form. - -1998-09-21 Aubrey Jaffer - - * primes.scm: Eliminated use of 1+. - (probably-prime?): #f for negative numbers. - -1998-09-19 Jorgen Schaefer - - * glob.scm (glob:match?? glob:match-ci??): fixed wrappers. - -1998-09-11 Aubrey Jaffer - - * Makefile (release): Uploads SLIB.html. - - * require.scm (*SLIB-VERSION*): Bumped from 2c2 to 2c3. - - * slib.texi (Filenames): documented pattern strings. - - * Makefile: Added $srcdir to TEXINPUTS for TeX. - -1998-09-10 Radey Shouman - - * schmooz.scm (schmooz): Added @args markup command. - -1998-09-09 Radey Shouman - - * schmooz.scm (schmooz): Now tries harder to determine whether a - definition is of a procedure or non-procedure variable. - Recognizes DEFMACRO, DEFINE-SYNTAX. - -1998-09-06 Aubrey Jaffer - - * slib.texi (Schmooz): Added documentation. - - * Makefile (info htmlform.txi): made smarter about when to run - schmooz. - -1998-09-03 Radey Shouman - - * schmooz.scm (scheme-args->macros): Now passed either a symbol, - for variable definition, or a possibly improper list, for - function/macro definition. For the variable definition case - generates @var{... for @0 instead of @code{... Now uses APPEND to - be more readable. - -1998-09-03 Aubrey Jaffer - - * slib.texi (Format): documentation moved to fmtdoc.txi. - - * glob.scm (filename:match?? filename:match-ci??): aliases added. - -1998-09-02 Radey Shouman - - * glob.scm: Added. - -1998-09-01 Aubrey Jaffer - - * primes.scm (primes:prngs): added to reduce likelyhood of - reentrant random calls. - -1998-08-31 Aubrey Jaffer - - * random.scm: rewritten using new seedable RNG. - - * randinex.scm (random:uniform): Rewritten for new RNG. - -1998-08-27 Aubrey Jaffer - - * primes.scm (primes:dbsp?): Now requires 'root and uses - integer-sqrt for sqrt on platforms not supporting inexacts. - -1998-08-25 - - * record.scm (rtd-name): Fixed so record rtds print. - -1998-08-16 Aubrey Jaffer - - * cring.scm (*): Number distribution requires separate treatment. - -1998-08-11 Aubrey Jaffer - - * factor.scm (prime:factor): (factor 0) now returns '(0) rather - than infinite-looping. - -1998-08-09 Aubrey Jaffer - - * cring.scm (*): Added check for (* -1 (- )) case. - -1998-07-08 Aubrey Jaffer - - * prec.scm (prec:warn): now takes arbitrary number of arguments. - (prec:nofix): - (prec:postfix): extra arguments are appended to the rules list; - not bound. - - * qp.scm (qp:qp): *qp-width* set to #f now the same as *qp-width* - set to 0 -- the full expressions are printed. - -1998-07-05 Aubrey Jaffer - - * prec.scm (prec:nofix): Added . binds args, which are combined - with *syn-rules*. - -1998-06-12 Aubrey Jaffer - - * Makefile (dist): Added cvs flag command to dist target. - -1998-06-08 Aubrey Jaffer - - * htmlform.scm (html:start-form): added rest of METHOD types. - (html:generate-form command->html): regularized argument order to - `command method action'. - - * dbutil.scm (add-domain): Changed from row:insert to row:update. - - * rdms.scm (write-database): was not returning status. - -1998-06-07 Aubrey Jaffer - - * strcase.scm (string-ci->symbol): added. - - * htmlform.scm ((command->html rdb command-table command method - action)): renamed from commands->html. Method argument added. - (query-alist->parameter-list): now removes whitespace between - symbols. - -Fri Jun 5 16:01:26 EDT 1998 Aubrey Jaffer - - * require.scm (*SLIB-VERSION*): Bumped from 2c1 to 2c2. - -1998-06-04 Aubrey Jaffer - - * schmooz.scm: Top-level procedure names changed to have `schmooz' - in them. - - * htmlform.scm: Schmooz documentation added for more procedures. - -1998-06-03 Aubrey Jaffer - - * schmooz.scm (document-args->macros): fixed for `rest arglists'. - (document-fun): fixed for `rest arglists'. - - * strsrch.scm (string-subst): added. - - * htmlform.scm (html:text-subst): removed. References changed to - STRING-SUBST. - -1998-06-02 radey - - * Makefile: Added schmooz.scm to ffiles. - - * schmooz.scm: Texinfo document generator for Scheme programs. - -1998-06-02 Aubrey Jaffer - - * htmlform.scm: Added documentation. - (http:send-error-page): scope of fluid-let was wrong. - - * paramlst.scm (check-parameters): now returns status rather than - signal error. - -1998-05-30 Aubrey Jaffer - - * batch.scm (write-batch-line): added. - (batch:write-comment-line): added so that - batch:call-with-output-script and batch:comment could share code. - (batch:write-header-comment): abstracted from - batch:call-with-output-script. - -1998-05-29 Aubrey Jaffer - - * htmlform.scm: Added http stuff. - -1998-05-24 Aubrey Jaffer - - * cring.scm (make-rat rat-*): Removed support for rational numbers. - -1998-05-14 Radey Shouman - - * logical.scm ((bit-field n start end)): Renamed from BIT-EXTRACT. - ((bitwise-if mask n0 n1)): - ((logical:copy-bit index to bool)): - ((logical:copy-bit-field to start end from)): added. - -Tue Apr 14 16:28:20 EDT 1998 Aubrey Jaffer - - * require.scm (*SLIB-VERSION*): Bumped from 2c0 to 2c1. - -1998-04-14 Aubrey Jaffer - - * byte.scm (bytes-length): added synonym for string-length. - -1998-04-14 - - * printf.scm ((stdio:iprintf out format-string . args)): Added - %b descriptor -- outputs a binary number representation. - -1998-03-31 - - * printf.scm ((stdio:iprintf out format-string . args)): Floating point - formatting implemented. - ((stdio:parse-float str)): ((stdio:round-string str ndigs strip-0s)): - Added. - -1998-03-11 Radey Shouman - - * require.scm (program-vicinity): Now gives more informative error - message when called from non-loading context. - -1998-02-10 William D Clinger - - * mwexpand.scm (mw:case exp): added. - - * mwdenote.scm (mw:denote-of-case): added. - -1998-02-12 Aubrey Jaffer - - * eval.scm (eval): Dynamic-binding was not the right paradigm. - Changed eval to simply bind identifiers around form to eval. - -1998-02-11 Aubrey Jaffer - - * slib.texi (Top): - (Extra-SLIB Packages): Converted to use of new texinfo feature - @url. - -1998-02-08 Aubrey Jaffer - - * eval.scm (interaction-environment): fixed. - -1998-02-02 Aubrey Jaffer & Radey Shouman - - * eval.scm (scheme-report-environment): implemented for version - arguments of 4 and 5. - -1998-02-01 Aubrey Jaffer - - * eval.scm (eval): R5RS proposed EVAL implemented. - -Sun Dec 7 22:34:50 1997 Aubrey Jaffer - - * getparam.scm (getopt->parameter-list getopt->arglist - parameter-list->getopt-usage): moved from paramlst.scm. - - * htmlform.scm (commands->html cgi:serve-command): added. - -Thu Dec 4 20:00:05 1997 Aubrey Jaffer - - * timezone.scm (read-tzfile): Now can fail without signaling an - error. - (tzfile:vicinity): moved here from "tzfile.scm" so we don't have - to load "tzfile.scm" to load a non-existant file. - -Sat Nov 29 22:55:23 1997 Aubrey Jaffer - - * paramlst.scm (parameter-list->getopt-usage): split out of - getopt->parameter-list. - -Wed Nov 26 23:49:53 1997 Aubrey Jaffer - - * printf.scm (stdio:sprintf): Now creates and returns string if - first argument is #f or an integer (which bounds string). Fixed - some bugs. - -Sun Nov 23 12:31:27 1997 Aubrey Jaffer - - * Bev2slib.scm: created. Converts Stephen Bevan's "*.map" files - to SLIB catalog entries. - - * require.scm (require:require): Calls catalog:get instead of - require:feature->path so symbol-redirected feature names are added - to *features* when file is loaded. - -Mon Nov 17 21:05:59 1997 Aubrey Jaffer - - * dbrowse.scm (browse): changed default table to #f so that full - *catalog-data* can be browsed. Documented. - -Sat Nov 15 00:15:33 1997 Aubrey Jaffer - - * cltime.scm (decode-universal-time encode-universal-time): - corrected for (now working) timezones. - - * tzfile.scm (tzfile-read tz-index): added to read Linux (sysV ?) - timezone files. - - * byte.scm: added `bytes', arrays of small integers. - -Thu Nov 13 22:28:15 1997 Aubrey Jaffer - - * record.scm (display write): Records now display and write as - #. - -Sun Nov 9 23:45:46 1997 Aubrey Jaffer - - * timezone.scm: added. Processes TZ environment variable to - timezone information. - (tzset): takes optional string or timezone argument and returns - the current timezone. - (time-zone): creates and returns a timezone from a string filename - or TZ spec *without* setting global variables. - (daylight? *timezone* tzname): Posix (?) global variables are - set but SLIB code doesn't depend on them. - - * psxtime.scm (time:gmktime time:gtime): added to fill out - orthogonal function set. The local time functions (localtime - mktime ctime) now all take optional timezone arguments. - (time:localtime): cleaned interface to timezone.scm: just calls to - tzset and tz:params. - -Mon Oct 20 22:18:16 1997 Radey Shouman - - * arraymap.scm (array-index-map!): Added. - (array-indexes): implemented with array-index-map! - -Sun Nov 2 22:59:59 1997 Aubrey Jaffer - - * require.scm (*SLIB-VERSION*): Bumped from 2b3 to 2c0. - - * require.scm (catalog:get): Now loads "homecat" and "usercat" - catalogs in HOME and current directories. - (catalog/require-version-match?): debugged for dumped executables. - ((require #f)): resets *catalog*. - ((require 'new-catalog)): builds new catalog. - - * mklibcat.scm: Rewrote to output headers and combine - implementation and site specific catalogs into "slibcat". - - * slib.texi (The Library System): Added chapter. Totally - reorganized the Manual. - -Wed Oct 29 22:49:15 1997 Aubrey Jaffer - - * Template.scm *.init (home-vicinity): added. - - * require.scm (catalog:try-read): split off from - catalog:try-impl-read; useful for reading catalogs from other - vicinities. - -Thu Oct 23 23:14:33 1997 Eric Marsden - - * factor.scm (prime:product): added EXACT? test. - -Mon Oct 20 19:33:41 1997 Aubrey Jaffer - - * slib.texi (Database Utilities): Rewrote and expanded - command-line parser example. - - * paramlst.scm (getopt->parameter-list): Added "Usage" printer - for strange option chars. - - * comlist.scm (coerce): Added 'integer as an alias for 'number. - -Sat Oct 18 13:03:24 1997 Aubrey Jaffer - - * strsrch.scm (string-index-ci string-reverse-index-ci - substring-ci): added. - - * comlist.scm (comlist:butnthcdr): added by analogy with butlast. - -Sun Oct 5 15:16:17 1997 Aubrey Jaffer - - * scsh.init: Added (thanks to Tomas By). - -Fri Oct 3 20:50:32 1997 Aubrey Jaffer - - * comparse.scm (read-command): now correctly handles \^M^J - (continued lines). - (read-options-file): added. Parses multi-line files of options. - -Fri Sep 19 22:52:15 1997 Aubrey Jaffer - - * paramlst.scm (fill-empty-parameters getopt->arglist): defaults - argument renamed to defaulters; documentation corrected. - -Tue Aug 26 17:41:39 1997 Aubrey Jaffer - - * batch.scm: Changed sun to sunos as platform name. - -Mon Aug 25 12:40:45 1997 Aubrey Jaffer - - * require.scm (catalog:version-match?): Now checks and issues - warning when *SLIB-VERSION* doesn't match first form in - "require.scm". - -Sun Aug 24 23:56:07 1997 Aubrey Jaffer - - * require.scm (catalog:version-match?): added to automatically - rebuild slibcat when SLIB with new version number is installed. - - * mklibcat.scm: *SLIB-VERSION* association now included in - slibcat. - -Sat Aug 23 11:35:20 1997 Aubrey Jaffer - - * selfset.scm: added. (define a 'a) .. (define z 'z). - -Sat Aug 23 09:32:44 EDT 1997 Aubrey Jaffer - - * require.scm (*SLIB-VERSION*): Bumped from 2b2 to 2b3. - -Thu Aug 21 10:20:21 1997 Aubrey Jaffer - - * determ.scm (determinant): added. - -Mon Jun 30 10:09:48 1997 Aubrey Jaffer - - * require.scm: "Supported by all implementations" section removed. - - * chez.init (defmacro:eval): Chez 5.0 no longer can support - defmacro; added SLIB autoload defmacro:expand*. - -Sun Jun 29 19:36:34 1997 Aubrey Jaffer - - * cring.scm (cring:db): cring now works for -, /, and ^. - -Thu Jun 26 00:19:05 1997 Aubrey Jaffer - - * cring.scm (expression-< x y): added to sort unreduced - expressions. - -Tue Jun 24 13:33:40 1997 Aubrey Jaffer - - * cring.scm: Added 'commutative-ring feature; extend + and * to - non-numeric types. - (cring:define-rule): Defines rules for + and * reduction of - non-numeric types. - -Mon Jun 23 22:58:44 EDT 1997 Aubrey Jaffer - - * require.scm (*SLIB-VERSION*): Bumped from 2b1 to 2b2. - -Sat Jun 21 23:20:29 1997 Aubrey Jaffer - - * alistab.scm (map-key for-each-key ordered-for-each-key): Now - take match-key argument. - (delete*): added. delete-assoc created to *not* accept wildcards - in delete keys. - - * rdms.scm (get* row:delete* row:remove*): Now take match-key - arguments, normalize them, and pass to base-table routines. - -Thu Jun 19 13:34:36 1997 Aubrey Jaffer - - * alistab.scm (assoc* make-assoc* delete-assoc* assoc*-for-each - assoc*-map sorted-assoc*-for-each alist-sort!): added. Functions - now support partial matches and key wild-carding. - (remover kill-table): remover removed. Kill-table uses - delete-assoc*. - -Sat Jun 14 22:51:51 1997 Aubrey Jaffer - - * alistab.scm (alist-table): Changed table handle from - (table-name . TABLE) to (#(table-name key-dim) . TABLE). - (alist-table): Changed primary keys from vectors to lists. - -Wed 28 May 1997 Dave Love - - * yasos.scm: Remove case-sensitivity (for Guile). Chop the - duplicated code. - -Mon May 26 21:46:45 1997 Bill Nell - - * strport.scm (call-with-output-string): losing every 512th - character fixed. - -Wed May 21 19:16:03 1997 Aubrey Jaffer - - * printf.scm (stdio:iprintf): changed integer-pad to - integer-convert and unified conversion of non-numeric values. - -Wed May 14 14:01:02 1997 Aubrey Jaffer - - * prec.scm (prec:symbolfy): added so that for most user grammar - functions, parsing defaults to the triggering token, instead of - the symbol @code{?}. - -Tue May 13 22:46:22 1997 Albert L. Ting - - * elk.init (slib:error): re-written. - -Sat May 10 22:00:30 EDT 1997 Aubrey Jaffer - - * require.scm (*SLIB-VERSION*): Bumped from 2b0 to 2b1. - -Wed May 7 15:11:12 1997 Aubrey Jaffer - - * prec.scm: Rewrote nearly all of JACAL parser and moved it here. - Now supports dynamic binding of grammar. - -Tue May 6 16:23:10 1997 Aubrey Jaffer - - * strsrch.scm (find-string-from-port?): Enhanced: can take char - instead of count and search up to char. Given procedure, tests it - on every character. - -Wed 30 Apr 1997 John David Stone - - * chez.init: Revised for Chez Scheme 5.0c - -Tue Apr 29 19:55:35 1997 Aubrey Jaffer - - * require.scm (*SLIB-VERSION*): Bumped from 2a7 to 2b0. - - * slib.texi (Library Catalog): section added to describe new - catalog mechanism. - - * Makefile (slib48): Now defines library-vicinity and - implementation-vicinity from the makefile. "slibcat" support - added. - -Sat Apr 12 23:40:14 1997 Aubrey Jaffer - - * mklibcat.scm: moved from "require.scm". Rebuilds "slibcat". - * require.scm (catalog:get): now caches *catalog* in - implementation-vicinity scheme files "slibcat" and "implcat". - -Wed Apr 9 20:55:31 1997 Dorai Sitaram - - * mbe.scm (hyg:map*): Added to correct a minor bug in the hygienic - half of mbe.scm that shows up only when define-syntax is used in a - right-hand pattern inside syntax-rules. - - * strsrch.scm (string-reverse-index): added. - -Tue Apr 8 16:46:35 1997 Aubrey Jaffer - - * yasos.scm: Replaces "yasyn.scm" and "object.scm"; Those and - "recobj.scm" were removed because of unclear copyright status. - - * printf.scm (stdio:iprintf): no longer translates \r to #\return. - -Sat Aug 10 16:11:15 1996 Mike Sperber - - * scheme48.init Makefile: Now makes use of module system to access - required primitives. Added install48 target to Makefile. - -Sat Apr 5 13:26:54 1997 Aubrey Jaffer - - * array.scm (array-dimensions): fixed off-by-1 bug. - -Sat Mar 8 17:44:34 1997 Aubrey Jaffer - - * scanf.scm (stdio:scan-and-set): corrected handling of %5c with - short input. - -Fri Mar 7 21:20:57 EST 1997 Aubrey Jaffer - - * require.scm (*SLIB-VERSION*): Bumped from 2a6 to 2a7. - -Sat Feb 22 10:18:36 1997 Aubrey Jaffer - - * batch.scm (system): added stubifier (returns #f) for when - system is not provided. - (system:success?): added. - - * wttree.scm (error): - (error:wrong-type-argument): - (error:bad-range-argument): Stubs added for non-MITScheme - implementations. - - * Template.scm *.init (slib:warn): added. - -Sun Feb 16 21:55:59 1997 Michael Pope - - * gambit.init (scheme-implementation-version): updated for Gambit - v2.4. - -Sun Dec 1 00:44:30 1996 Aubrey Jaffer - - * batch.scm (truncate-up-to): Added to support compiler habbit of - putting object files in current-directory. - -Sat Aug 31 12:17:30 1996 Aubrey Jaffer - - * scm.init: added for completeness - - * record.scm (vector?): infinite recursion fixed. - - * dbutil.scm (make-command-server): Documentation updated. - -Wed Aug 21 20:38:26 1996 John Gerard Malecki - - * vscm.init: Implements string ports using `generic ports'. - -Wed Aug 21 20:38:26 1996 Aubrey Jaffer - - * record.scm: rewritten to make records disjoint types - which are unforgable and uncorruptable by R4RS procedures. - -Fri Jul 19 11:24:45 1996 Aubrey Jaffer - - * structure.scm scaoutp.scm scamacr.scm scainit.scm scaglob.scm - scaexpp.scm: Added missing copyright notice and terms. - -Thu Jul 18 17:37:14 1996 Aubrey Jaffer - - * rbtest.scm rbtree.scm: removed for lack of copying permissions. - -Wed Jun 5 00:22:33 1996 Aubrey Jaffer - - * root.scm (newton:find-integer-root integer-sqrt newton:find-root - laguerre:find-root laguerre:find-root): added. - -Wed May 15 09:59:00 1996 Aubrey Jaffer - - * scanf.scm (stdio:scan-and-set): removed gratuitous char-downcase - by changing all (next-format-char) ==> (read-char format-port). - -Tue Apr 9 19:22:40 1996 Aubrey Jaffer - - * slib2a5 released. - - * mwtest.scm: removed from distribution for lack of copyright - info. - - * batch.scm (batch:apply-chop-to-fit): added - (batch:try-system): renamed from batch:system. - (batch:system): now signals error if line length over limit or - system calls fail. - -Sun Aug 20 19:20:35 1995 Gary Leavens - - * struct.scm (check-define-record-syntax check-variant-case-syntax): - - For using the file "struct.scm" with the EOPL book, one has to - make 2 corrections. To correct it, there are two places where "-" - has to be replaced by "->" as in the code below... - -Sat Apr 6 14:31:19 1996 Aubrey Jaffer - - * batch.scm (must-be-first must-be-last): added. - - * paramlst.scm (check-parameters): made error message more - informative. - -Mon Mar 18 08:46:36 1996 Aubrey Jaffer - - * modular.scm (modular:*): non-bignum symmetric modulus case was - dividing by 0. Algorithm still needs to be fixed. - -Mon Mar 13 00:41:00 1996 Aubrey Jaffer - - * slib2a4 released. - -Sat Mar 9 21:36:19 1996 Mikael Djurfeldt - - * tsort.scm (topological-sort): Added. - -Fri Mar 8 19:25:52 1996 Aubrey Jaffer - - * printf.scm: Removed use of string-ports. Cleaned up error - handling. - -Tue Mar 5 14:30:09 1996 Aubrey Jaffer - - * printf.scm (%a %A): General scheme output specifier added. - -Mon Feb 19 15:48:06 1996 Aubrey Jaffer - - * scanf.scm (stdio:scan-and-set): Removed flush-whitespace from - all conversion specifications per suggestion from - oleg@acm.org (Oleg Kiselyov). - -Sat Feb 3 00:02:06 1996 Oleg Kiselyov (oleg@acm.org) - - * strsrch.scm (string-index substring? find-string-from-port?): added. - -Mon Jan 29 23:56:33 1996 Aubrey Jaffer - - * printf.scm (stdio:iprintf): Rewrote for Posix compliance (+ - extensions which are both BSD and GNU). - -Sat Jan 27 09:55:03 1996 Aubrey Jaffer - - * FAQ: printf vs. format explained. - - * printf.scm: renamed from "stdio.scm". (require 'printf) now - brings in "printf.scm". - -Sun Jan 14 21:00:17 1996 Aubrey Jaffer - - * scanf.scm: Rewrote from scratch. - -Mon Oct 9 22:48:58 1995 Aubrey Jaffer (jaffer@jacal) - - * modular.scm (modular:invertable?): added. - -Wed Sep 27 10:01:04 1995 Aubrey Jaffer (jaffer@jacal) - - * debug.scm: augmented, reorganized, and split. - (print): removed. - - * break.scm: created. - - * qp.scm: created. - -Sun Sep 24 22:23:19 1995 Aubrey Jaffer (jaffer@jacal) - - * require.scm (*catalog*): test.scm removed. - -Sun Sep 17 21:32:02 1995 Aubrey Jaffer (jaffer@jacal) - - * modular.scm: rewritten so that if modulus is: - positive? -- work as before (Z_modulus) - zero? -- perform integer operations (Z) - negative? -- perform operations using symmetric - representation (Z_(1-2*modulus)) - (symmetric:modulus modulus->integer modular:normalize): added. - (modular:*): not completed for fixnum-only implementations. - -Sat Sep 9 16:53:22 1995 Aubrey Jaffer (jaffer@jacal) - - * slib.texi (Legacy): added for t, nil, last-pair, and identity, - which are now required of all implementations. - -Mon Aug 28 00:42:29 1995 Aubrey Jaffer (jaffer@jacal) - - * require.scm (require:feature->path require:provided? - require:require): cleaned up. feature->path now returns a path, - whether the module is loaded or not. - -Sun Aug 27 11:05:19 1995 Aubrey Jaffer (jaffer@jacal) - - * genwrite.scm (generic-write): Fixed "obj2str" - OBJECT->LIMITED-STRING non-terminating wr-lst for cases like - (set-car! foo foo). - - * obj2str.scm (object->limited-string): uncommented. - -Sun Aug 20 17:10:40 1995 Stephen Adams - - * wttest.scm wttree.scm: Weight Balanced Trees added. - -Sun Aug 20 16:06:20 1995 Dave Love - - * tree.scm yasyn.scm collect.scm: Uppercase identifiers changed to - lower case for compatability with case sensitive implementations. - -Sat Aug 19 21:27:55 1995 Aubrey Jaffer (jaffer@jacal) - - * arraymap.scm (array-copy!): added. - - * primes.scm (primes:primes< primes:primes>): primes:primes split - into ascending and descending versions. - -Sun Jul 16 22:44:36 1995 Aubrey Jaffer (jaffer@jacal) - - * makcrc.scm (make-port-crc): added. POSIX.2 checksums. - -Mon Jun 12 16:20:54 1995 Aubrey Jaffer (jaffer@jacal) - - * synclo.scm (internal-syntactic-environment - top-level-syntactic-environment): replaced call to alist-copy. - - * require.scm (*catalog*): 'schelog, 'primes, and 'batch added. - 'prime renamed to 'factor. - - From: mhc@edsdrd.eds.com (Michael H Coffin) - * primes.scm (primes probably-prime?): added. prime.scm renamed - to factor.scm. - -Fri Mar 24 23:35:25 1995 Matthew McDonald - - * struct.scm (define-record): added field-setters. - -Sun Jun 11 23:36:55 1995 Aubrey Jaffer (jaffer@jacal) - - * batch.scm: added - - * Makefile (schelogfiles): SLIB schelog distribution created. - -Mon Apr 17 15:57:32 1995 Aubrey Jaffer (jaffer@jacal) - - * comlist.scm (coerce type-of): added. - - * debug.scm (debug:qp): with *qp-width* of 0 just `write's. - - * paramlst.scm (getopt->parameter-list): Now accepts long-named - options. Now COERCEs according to types. - -Sat Apr 15 23:15:26 1995 Aubrey Jaffer (jaffer@jacal) - - * require.scm (require:feature->path): Returns #f instead of - string if feature not in *catalog* or *modules*. - -Sun Mar 19 22:26:52 1995 Aubrey Jaffer (jaffer@jacal) - - * getopt.scm (getopt-- argc argv optstring): added wrapper for - getopt which parses long-named-options. - -Tue Feb 28 21:12:14 1995 Aubrey Jaffer (jaffer@jacal) - - * paramlst.scm (parameter-list-expand expanders parms): added. - -Mon Feb 27 17:23:54 1995 Aubrey Jaffer (jaffer@jacal) - - * report.scm (dbutil:print-report): added. - - * comparse.scm (read-command): added. Reads from a port and - returns a list of strings: the arguments (and options). - -Sat Feb 25 01:05:25 1995 Aubrey Jaffer (jaffer@jacal) - - * repl.scm (repl:repl): Added loop, conditional on CHAR-READY? - being PROVIDED?, which reads through trailing white-space. - -Sun Feb 5 16:34:03 1995 Aubrey Jaffer (jaffer@jacal) - - * paramlst.scm ((make-parameter-list parameter-names)): - ((fill-empty-parameters defaults parameter-list)): - ((check-parameters checks parameter-list)): - ((parameter-list->arglist positions arities parameter-list)): - ((parameter-list-ref parameter-list i)): - ((adjoin-parameters! parameter-list parameters)): - Procedures for making, merging, defaulting, checking and - converting `parameter lists' (named parameters). - ((getopt->parameter-list argc argv optnames arities aliases)): - ((getopt->arglist argc argv optnames positions - arities defaults checks aliases)): - Procedures for converting options and arguments processed by - getopt to parameter-list or arglist form. - - * dbutil.scm ((make-command-server rdb command-table)): added - procedure which calls commands and processes parameters. - - * rdms.scm ((make-relational-system base)): add-domain and - delete-domain commands moved to "dbutil.scm" (create-database). - -Fri Feb 3 11:07:46 1995 Aubrey Jaffer (jaffer@jacal) - - * debug.scm (debug:tracef debug:untracef): removed (duplicates of - code in "trace.scm"). - (trace-all): utility to trace all defines in a file added. - -Thu Jan 19 00:26:14 1995 Aubrey Jaffer (jaffer@jacal) - - * logical.scm (logbit? logtest): added. - -Sun Jan 15 20:38:42 1995 Aubrey Jaffer (jaffer@jacal) - - * dbutil.scm (dbutil:create-database)): Added parameter - description tables for "commands". - - * require.scm (software-type): standardize msdos -> ms-dos. - -Mon Jan 2 10:26:45 1995 Aubrey Jaffer (jaffer@jacal) - - * comlist.scm (comlist:atom?): renamed from comlist:atom. - - * scheme48.init (char->integer integer->char): Now use integers in - the range 0 to 255. Fixed several other problems. - (modulo): Worked around negative modulo bug. - - * Makefile (slib48): `make slib48' loads "scheme48.init", `,dump's - a scheme48 image file, and creates an `slib48' shell script to - invoke it. - - * hash.scm (hash:hash-number): no longer does inexact->exact to - exacts, etc. - - * trnscrpt.scm (read): no longer transcripts eof-objects. - - From: johnm@vlibs.com (John Gerard Malecki) - * priorque.scm (heap:heapify): internal defines incorrectly - dependent on order-of-eval replaced with let*. - -Thu Dec 22 13:28:16 1994 Aubrey Jaffer (jaffer@jacal) - - * dbutil.scm (open-database! open-database create-database): This - enhancement wraps a utility layer on `relational-database' which - provides: - * Automatic loading of the appropriate base-table package when - opening a database. - * Automatic execution of initialization commands stored in - database. - * Transparent execution of database commands stored in - `*commands*' table in database. - -Wed Dec 21 22:53:57 1994 Aubrey Jaffer (jaffer@jacal) - - * rdms.scm (make-relational-system base): Now more careful about - protecting read-only databases. - -Mon Dec 19 00:06:36 1994 Aubrey Jaffer (jaffer@jacal) - - * dbutil.scm (dbutil:define-tables): added utility which provides: - Data definition from Scheme lists for any SLIB - relational-database. - -Sat Dec 17 12:10:02 1994 Aubrey Jaffer (jaffer@jacal) - - * alistab.scm rdms.scm (make-getter row-eval): evaluation of - `expression' fields no longer done when retrieved from base - tables (which made copying of many tables impossible). - - * alistab.scm - (write-base): rewrote to not use pretty-print. - - * sc3.scm: removed (only contained last-pair, t, and nil). - - * Template.scm scheme48.init vscm.init (last-pair t nil): added. - -Thu Dec 8 00:02:18 1994 Aubrey Jaffer (jaffer@jacal) - - * mularg.scm pp.scm ratize.scm: copyright line removed from files - (still lacking terms) less than 12 lines. - - From: johnm@vlibs.com (John Gerard Malecki) - * sort.scm (sort:sort!): long standing bug in sort! with vector - argument fixed. - -Thu Dec 1 17:10:24 1994 Aubrey Jaffer (jaffer@jacal) - - * *.scm: Most missing copyright notices supplied. - -Sun Nov 27 23:57:41 1994 Aubrey Jaffer (jaffer@jacal) - - * rdms.scm (make-relational-system base): now checks field types - when table is opened. Domains table now has foreign-table field. - (for-each-row): ordered for-each function added. - * alistab.scm (ordered-for-each-key supported-key-type?): added. - -Thu Oct 27 12:20:41 1994 Tom Tromey - - * priorque.scm: Renamed everything to conform to coding standards - and updated docs. Changed names: heap-extract-max to - heap-extract-max!, heap-insert to heap-insert! and heap-size to - heap-length. - -Sat Nov 26 22:52:31 1994 Aubrey Jaffer (jaffer@jacal) - - * Template.scm *.init (identity): Now required; moved from - "comlist.scm". - - * alistab.scm (alist-table): Converted to representing rows as - lists. Non-row operations removed. - - * rdms.scm (make-relational-system base): Most individual column - operations removed. Only get and get* remain. Row operations - renamed. Row inserts and updates distinguished. - -Tue Nov 15 16:37:16 1994 Aubrey Jaffer (jaffer@jacal) - - * rdms.scm (make-relational-system base): Generalized database - system inspired by the Relational Model. - - * alistab.scm (alist-table): Base table implementation suitable - for small databases and testing rdms.scm. - -Tue Oct 25 22:36:01 1994 Aubrey Jaffer (jaffer@jacal) - - From: Tommy Thorn - * chez.init (scheme-implementation-version): fixed (changed to "?"). - (library-vicinity): The definition of library-vicinity used - getenv, which was defined later. - (slib:chez:quit): The definition of slib:chez:quit was illegal. - Fixed. - (chez:merge!): had a typo. - (defmacro:load): (require 'struct) didn't work, because defmacro:load - doesn't add suffix. Workaround: defmacro:load and macro:load is - the same as slib:load-source. - -Wed Oct 19 11:44:12 1994 Aubrey Jaffer (jaffer@jacal) - - * require.scm time.scm cltime.scm (difftime offset-time): added to - allow 'posix-time functions to work with a non-numeric type - returned by (current-time). - -Tue Aug 2 10:44:32 1994 Aubrey Jaffer (jaffer@jacal) - - * repl.scm (repl:top-level repl:repl): Multiple values at top - level now print nicely. - -Sun Jul 31 21:39:54 1994 Aubrey Jaffer (jaffer@jacal) - - * cltime.scm (get-decoded-time get-universal-time - decode-universal-time encode-universal-time): - Common-Lisp time conversion routines created. - - * time.scm (*timezone* tzset gmtime localtime mktime asctime ctime): - Posix time conversion routines created. - -Mon Jul 11 14:16:44 1994 Aubrey Jaffer (jaffer@jacal) - - * Template.scm mitscheme.init scheme2c.init t3.init (*features*): - trace added. - -Fri Jul 8 11:02:34 1994 Aubrey Jaffer (jaffer@jacal) - - * chap.scm ((chap:string did not include the expression and the - expression, instead it incorrectly included the - expression. (rf. R4RS, 4.2.4) - (hyg:tag-lambda): the body of a lambda expression should be - generated using hyg:tag-generic instead of hyg:tag-vanilla. This - allows expressions within lambda to behave hygienically. - (hyg:tag-let): extended to support `named let'. - -Sun Apr 10 00:22:04 1994 Aubrey Jaffer (jaffer@jacal) - - * README: INSTALLATION INSTRUCTIONS greatly improved. - * Template.scm *.init: Path configurations move to top of files - for easier installation. - - * FAQ: File of Frequently Asked Questions and answers added. - -Sat Apr 9 21:28:46 1994 Aubrey Jaffer (jaffer@jacal) - - * slib.texi (Vicinity): scheme-file-suffix removed. Use - slib:load or slib:load-source instead. - -Wed Apr 6 00:55:16 1994 Aubrey Jaffer (jaffer@jacal) - - * require.scm (slib:report): - (slib:report-version): - (slib:report-locations): added to display SLIB configuration - information. - -Mon Apr 4 08:48:37 1994 Aubrey Jaffer (jaffer@jacal) - - * Template.scm *.init (slib:exit): added. - -Fri Apr 1 14:36:46 1994 Aubrey Jaffer (jaffer@jacal) - - * Makefile (intro): Added idiot message for those who make. - Cleaned up and reorganized Makefile. - -Wed Mar 30 00:28:30 1994 Aubrey Jaffer (jaffer@jacal) - - * Template.scm *.init ((slib:eval-load evl)): created - to service all macro loads. - - From: whumeniu@datap.ca (Wade Humeniuk) - * recobj.scm yasyn.scm: added. These implement RECORDS and - YASOS using object.scm object system. - -Sun Mar 6 01:10:53 1994 Aubrey Jaffer (jaffer@jacal) - - From: barnett@armadillo.urich.edu (Lewis Barnett) - * gambit.init (implementation-vicinity library-vicinity): Relative - pathnames for Slib in MacGambit. - - From: lucier@math.purdue.edu (Brad Lucier) - * random.scm (random:random random:chunks/float): fixed off-by-one - and slop errors. - -Thu Mar 3 23:06:41 1994 Aubrey Jaffer (jaffer@jacal) - - From: lutzeb@cs.tu-berlin.de (Dirk Lutzebaeck) - * format.scm slib.texi: Format 3.0. - * format's configuration is rearranged to fit only into SLIB. All - implementation dependent configurations are done in the SLIB init files - * format's output routines rely on call-with-output-string now if - output to a string is desired - * The floating point formatting code (formatfl.scm) moved into - format.scm so that there is only one source code file; this - eliminates the configuration of the load path for the former - formatfl.scm and the unspecified scope of the load primitive - * floating point formatting doesn't use any floating point operation or - procedure except number->string now; all formatting is now based - solely on string, character and integer manipulations - * major rewrite of the floating point formatting code; use global - buffers now - * ~f,~e,~g, ~$ may use also number strings as an argument - * ~r, ~:r, ~@r, ~:@r roman numeral, and ordinal and cardinal - English number printing added (from dorai@cs.rice.edu) - * ~a has now a working `colinc' parameter - * ~t tabulate directive implemented - * ~/ gives a tabulator character now (was ~T in version < 2.4) - * ~& fresh line directive implemented - * ~@d, ~@b, ~@o and ~@x now has the CL meaning (plus sign printed) - automatic prefixing of radix representation is removed - * ~i prints complex numbers as ~f~@fi with passed parameters - * ~:c prints control characters like emacs (eg. ^C) and 8bit characters - as an octal number - * ~q gives information and copyright notice on this format implementation - ~:q gives format:version - * case type of symbol conversion can now be forced (see - format:symbol-case-conv in format.scm) - * case type of the representation of internal objects can now be - forced (see format:iobj-case-conv format.scm) - * format error messages are now printed on the current error port - if available by the implementation - * format now accepts a number as a destination port; the output - is then always directed to the current error port if available by - the implementation - * if format's destination is a string it is regarded as a format string now - and output is the current output port; this is a contribution to - Scheme->C to use format with the runtime system; the former semantics - to append tothe destination string is given up - * obj->string syntax change and speedup - * tested with scm4d, Elk 2.2, MIT Scheme 7.1, Scheme->C 01Nov91 - - -Wed Mar 2 13:16:37 1994 Aubrey Jaffer (jaffer@jacal) - - From: Matthias Blume - * vscm.init: added. - -Fri Feb 18 23:51:41 1994 Aubrey Jaffer (jaffer@jacal) - - From: jjb@isye.gatech.edu (John Bartholdi) - * macscheme.init: added. - -Thu Feb 17 01:19:47 1994 Aubrey Jaffer (jaffer@jacal) - - * ppfile.scm ((pprint-filter-file inport filter outport)): added. - Useful for pre-expanding macros. Preserves top-level comments. - -Wed Feb 16 12:44:34 1994 Aubrey Jaffer (jaffer@jacal) - - From: dorai@cs.rice.edu (Dorai Sitaram) - * mbe.scm: Macro by Example define-syntax using defmacro. - -Tue Feb 15 17:18:56 1994 Aubrey Jaffer (jaffer@jacal) - - From: whumeniu@datap.ca (Wade Humeniuk) - * object.scm: Macroless Object System - -Mon Feb 14 00:48:18 1994 Aubrey Jaffer (jaffer@jacal) - - * defmacex.scm (defmacro:expand*): replaces "defmacro.scm". Other - defmacro functions now supported in all implementations. - -Sun Feb 13 12:38:39 1994 Aubrey Jaffer (jaffer@jacal) - - * defmacro.scm (defmacro:macroexpand*): now expands quasiquotes - correctly. - -Sat Feb 12 21:23:56 1994 Aubrey Jaffer (jaffer@jacal) - - * hashtab.scm ((predicate->hash pred)): moved from hash.scm. - -Tue Feb 8 01:07:00 1994 Aubrey Jaffer (jaffer@jacal) - - * Template.scm *.init (slib:load-source slib:load-compiled - slib:load): support for loading compiled modules added. - Dependence on SCHEME-FILE-SUFFIX removed. - - * require.scm (require:require): Added support for 'source and - 'compiled features. - -Sat Feb 5 00:19:38 1994 Aubrey Jaffer (jaffer@jacal) - - * stdio.scm ((stdio:sprintf)): Now truncates printing if you run - out of string. - -Fri Feb 4 00:54:14 1994 Aubrey Jaffer (jaffer@jacal) - - From: pk@kaulushaikara.cs.tut.fi (Kellom'ki Pertti) - * (psd/primitives.scm): Here is a patch removing some problems - with psd-1.1, especially when used with Scheme 48. Thanks to - Jonathan Rees for poiting them out. The patch fixes two problems: - references to an unused variable *psd-previous-line*, and the - correct number of arguments to write-char. - -Fri Jan 14 00:37:19 1994 Aubrey Jaffer (jaffer@jacal) - - * require.scm (require:require): Now supports (feature . - argument-list) associations. - -Sat Nov 13 22:07:54 1993 (jaffer at jacal) - - * slib.info (Structures): added. Bug - struct.scm and - structure.scm do not implement the same macros. - -Mon Nov 1 22:17:01 1993 (jaffer at jacal) - - * array.scm (array-dimensions array-rank array-in-bounds?): - added. - -Sat Oct 9 11:54:54 1993 (jaffer at jacal) - - * require.scm (*catalog* portable-scheme-debugger): support added - for psd subdirectory. - -Tue Sep 21 11:48:26 1993 Aubrey Jaffer (jaffer at wbtree) - - * Makefile (lineio.scm rbtree.scm rbtest.scm scmacro.scm - sc4sc3.scm scaespp.scm scaglob.scm scainit.scm scamacr.scm - scaoutp.scm strcase.scm): hyphens removed from names. - -Mon Sep 20 00:57:29 1993 (jaffer at jacal) - - * arraymap.scm (array-map! array-for-each array-indexes): added. - -Sun Sep 19 19:20:49 1993 (jaffer at jacal) - - * require.scm (require:feature->path require:require *catalog*): - associations of the form (symbol1 . symbol2) in *catalog* look up - symbol2 whenever symbol1 is specified. - -Mon Sep 13 22:12:00 1993 (jaffer at jacal) - - From: sperber@provence.informatik.uni-tuebingen.de (Michael Sperber) - * elk.init: updated to ELK version 2.1. - -Sat Sep 11 21:17:45 1993 (jaffer at jacal) - - * hashtab.scm (hash-for-each): fixed and documented (also - documented alist.scm). - -Fri Sep 10 15:57:50 1993 (jaffer at jacal) - - * getopt.scm (getopt *optind* *optarg*): added. - -Tue Sep 7 23:57:40 1993 (jaffer at jacal) - - * slib1d3 released. - * comlist.scm: prefixed all functions with "comlist:". - -Tue Aug 31 23:59:28 1993 (jaffer at jacal) - - * Template.scm *.init (output-port-height): added. - -Wed May 26 00:00:51 1993 Aubrey Jaffer (jaffer at camelot) - - * hashtab.scm (hash-map hash-for-each): added. - * alist.scm (alist-map alist-for-each): added. - -Tue May 25 22:49:01 1993 Aubrey Jaffer (jaffer at camelot) - - * comlist.scm (delete delete-if atom): renamed as in common lisp. - * comlist.scm (delete-if-not): added. - * tree.scm: moved tree functions out of comlist.scm - -Mon May 24 10:28:22 1993 Aubrey Jaffer (jaffer at camelot) - - From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) - * modular.scm: improvements and fixed bug in modular:expt. - -Fri May 14 01:26:44 1993 Aubrey Jaffer (jaffer at camelot) - - * slib1d2 released. - - From: Dave Love - * comlist.scm: added some tree functions. - * yasos.scm collect.scm: fixed name conflicts and documentation. - -Tue May 11 01:22:40 1993 Aubrey Jaffer (jaffer at camelot) - - * eval.scm: removed because all *.init files support it. - - * hash.scm: made all hash functions case-insensitive. Equal - inexact and exact numbers now hash to the same code. - - From: eigenstr@falstaff.cs.rose-hulman.edu: - * slib.texi: revised. - -Sun May 9 01:43:11 1993 Aubrey Jaffer (jaffer at camelot) - - From: kend@newton.apple.com (Ken Dickey) - * macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm: Macros no - longer expand builtin Scheme forms. - - From: William Clinger - * macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm: Macros that - work added. - -Sat May 1 23:55:42 1993 Aubrey Jaffer (jaffer at montreux) - - * random.scm (random:random): sped up for exact arguments. - -Wed Apr 28 00:24:36 1993 Aubrey Jaffer (jaffer at camelot) - - From: lutzeb@flp.cs.tu-berlin.de (Dirk Lutzebaeck) - * format.scm formatfl.scm formatst.scm slib.texi: Format 2.3. - * implemented floating point support ~F,~E,~G,~$ - * automatic detection if the scheme interpreter support flonums. - * the representation of internal objects can be selected to be - #<...> or #[...] or other forms - * new/redefintion of configuration variables format:abort, - format:floats, format:formatfl-path, format:iobj-pref, format:iobj-post - * added string-index - * added MIT Scheme 7.1 custom types - * for efficiencies reasons the error continuation is only used if - format:abort is not available - * improved error presentation and error handling - * tested with scm4b/c, Elk 2.0, MIT Scheme 7.1, Scheme->C 01Nov91, - UMB Scheme 2.5/2.10 - -Sun Apr 25 22:40:45 1993 Aubrey Jaffer (jaffer at camelot) - - From: Dave Love - * scheme2c.init: corrections and portability improvements. - * yasos.scm collect.scm: -These correct the scheme2c.init and a couple of other things as well as -hiding some non-exported definitions and removing an example from -collect.scm to the manual. - -Sat Apr 3 00:48:13 1993 Aubrey Jaffer (jaffer at camelot) - - From: eigenstr@cs.rose-hulman.edu (Todd R. Eigenschink) - * slib.texi: created. - -Thu Mar 25 01:47:38 1993 Aubrey Jaffer (jaffer at camelot) - - From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) - * sca-init.scm sca-glob.scm sca-macr.scm sca-outp.scm - sca-expp.scm: syntax-case macros added. - -Wed Mar 24 23:12:49 1993 Aubrey Jaffer (jaffer at camelot) - - * comlist.scm (some every notany notevery): Now accept multiple - arguments. NOTANY added. - -Wed Mar 3 01:19:11 1993 Aubrey Jaffer (jaffer at camelot) - - From: "Dan Friedman" - * struct.scm structst.scm: added. - -Tue Mar 2 00:28:00 1993 Aubrey Jaffer (jaffer at camelot) - - * obj2str (object->string): now handles symbols and number without - going to string-port. - -Sun Feb 28 22:22:50 1993 Aubrey Jaffer (jaffer at camelot) - - * all files with Jaffer copyright: Now have explicit conditions - for use and copying. - -Fri Feb 26 00:29:18 1993 Aubrey Jaffer (jaffer at camelot) - - * obj2str: redefined in terms of string ports. - - * pp2str: eliminated. - -Mon Feb 22 17:21:21 1993 Aubrey Jaffer (jaffer at camelot) - - From: dorai@cs.rice.edu (Dorai Sitaram) - * strport.scm: string ports. - - From: Alan@LCS.MIT.EDU (Alan Bawden) - * array.scm: functions which implement arrays. - -Wed Feb 17 00:18:57 1993 Aubrey Jaffer (jaffer at camelot) - - * repl.scm: split off from sc-macro.scm. - - * eval.scm *.init Template.scm (eval!): eliminated. - - From: dorai@cs.rice.edu (Dorai Sitaram) - * defmacro.scm: added. Chez, elk, mitscheme, scheme2c, and scm - support. - -Tue Feb 16 00:23:07 1993 Aubrey Jaffer (jaffer at camelot) - - * require.doc (output-port-width current-error-port tmpnam - file-exists? delete-file force-output char-code-limit - most-positive-fixnum slib:tab slib:form-feed error):descriptions - added. - - * *.init (tmpnam): now supported by all. - - From: dorai@cs.rice.edu (Dorai Sitaram) - * chez.init elk.init mitscheme.init scheme2c.init (defmacro macro? - macro-expand): added. - -Mon Feb 15 00:51:22 1993 Aubrey Jaffer (jaffer at camelot) - - * Template.scm *.init (file-exists? delete-file): now defined for - all implementations. - -Sat Feb 13 23:40:22 1993 Aubrey Jaffer (jaffer at camelot) - - * chez.init (slib:error): output now directed to - (current-error-port). - -Thu Feb 11 01:23:25 1993 Aubrey Jaffer (jaffer at camelot) - - * withfile.scm (with-input-from-file with-output-from-file): now - close file on thunk return. - - * *.init (current-error-port): added. - -Wed Feb 10 17:57:15 1993 Aubrey Jaffer (jaffer at camelot) - - * mitscheme.init (values dynamic-wind): added to *features*. - - From: mafm@cs.uwa.edu.au (Matthew MCDONALD) - * mitcomp.pat: added patch file of definitions for compiling SLIB - with MitScheme. - -Tue Feb 9 10:49:12 1993 Aubrey Jaffer (jaffer at camelot) - - From: jt@linus.mitre.org (F. Javier Thayer) - * t3.init: additions and corrections. - -Mon Feb 8 20:27:18 1993 Aubrey Jaffer (jaffer at camelot) - - From: dorai@cs.rice.edu (Dorai Sitaram) - * chez.init: added. - -Wed Feb 3 23:33:49 1993 Aubrey Jaffer (jaffer at camelot) - - * sc-macro.scm (macro:repl): now prints error message for errors. - -Mon Feb 1 22:22:17 1993 Aubrey Jaffer (jaffer at camelot) - - * logical.scm (logor): changed to logior to be compatible with - common Lisp. - -Fri Jan 29 17:15:03 1993 Aubrey Jaffer (jaffer at camelot) - - From: jt@linus.mitre.org (F. Javier Thayer) - * t3.init: modified so it passes most of SCM/test.scm. - -Sun Jan 24 00:18:13 1993 Aubrey Jaffer (jaffer at camelot) - - * comlist.scm (intersection): added. - -Wed Jan 13 19:01:11 1993 Aubrey Jaffer (jaffer at camelot) - - * debug.scm: (debug:qp): needed to shadow quotient. - -Sat Jan 9 13:44:44 1993 Aubrey Jaffer (jaffer at camelot) - - * rb-tree.scm: changed use of '() and NULL? to #f and NOT. - - * rb-tree.scm (rb-insert! rb-delete!) added ! to names. - -Fri Jan 8 01:17:16 1993 Aubrey Jaffer (jaffer at camelot) - - * rb-tree.doc: added. - - From: pgs@ai.mit.edu (Patrick Sobalvarro) - * rb-tree.scm rbt-test.scm: code for red-black trees added. - -Tue Jan 5 14:57:02 1993 Aubrey Jaffer (jaffer at camelot) - - From: lutzeb@cs.tu-berlin.de (Dirk Lutzebaeck) - * format.scm formatst.scm format.doc: version 2.2 - * corrected truncation for fixed fields by negative field parameters - inserted a '<' or a '>' when field length was equal to object string - length - * changed #[...] outputs to #<...> outputs to be conform to SCM's - display and write functions - * changed #[non-printable-object] output to # - * ~:s and ~:a print #<...> messages in strings "#<...>" so that the - output can always be processed by (read) - * changed implementation dependent part: to configure for various scheme - systems define the variable format:scheme-system - * format:version is a variable returning the format version in a string - * format:custom-types allows to use scheme system dependent predicates - to identify the type of a scheme object and its proper textual - representation - * tested with scm4a14, Elk 2.0 - -Tue Dec 22 17:36:23 1992 Aubrey Jaffer (jaffer at camelot) - - * Template.scm *.init (char-code-limit): added. - - * debug.scm (qp): qp-string had bug when printing short strings - when room was less than 3. - - * random.scm (random:size-int): now takes most-positive-fixnum - into account. - -Wed Nov 18 22:59:34 1992 Aubrey Jaffer (jaffer at camelot) - - From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) - * randinex.scm (random:normal-vector! random:normal - random:solid-sphere random:hollow-sphere): new versions fix bug. - -Tue Nov 17 14:00:15 1992 Aubrey Jaffer (jaffer at Ivan) - - * str-case.scm (string-upcase string-downcase string-capitalize - string-upcase! string-downcase! string-capitalize!): moved from - format.scm. - -Fri Nov 6 01:09:38 1992 Aubrey Jaffer (jaffer at Ivan) - - * require.scm (require): uses base:load instead of load. - - * sc-macro.scm (macro:repl): now uses dynamic-wind. - -Mon Oct 26 13:21:04 1992 Aubrey Jaffer (jaffer at Ivan) - - * comlist.scm (nthcdr last) added. - -Sun Oct 25 01:50:07 1992 Aubrey Jaffer (jaffer at Ivan) - - * line-io.scm: created - -Mon Oct 19 12:53:01 1992 Aubrey Jaffer (jaffer at camelot) - - From: dorai@cs.rice.edu - * fluidlet.scm: FLUID-LET that works. - -Thu Oct 8 22:17:01 1992 Aubrey Jaffer (jaffer at camelot) - - From: Robert Goldman - * mitscheme.init: improvements. - -Sun Oct 4 11:37:57 1992 Aubrey Jaffer (jaffer at camelot) - - * values.scm values.doc: Documentation rewritten and combined - into values.scm - -Thu Oct 1 23:29:43 1992 Aubrey Jaffer (jaffer at Ivan) - - * sc-macro.scm sc-macro.doc: documentation improved and moved into - sc-macro.doc. - -Mon Sep 21 12:07:13 1992 Aubrey Jaffer (jaffer at Ivan) - - * sc-macro.scm (macro:load): now sets and restores *load-pathname*. - - * eval.scm (slib:eval!): (program-vicinity) now correct during - evaluation. - - * Template.scm, *.init: i/o-redirection changed to with-file. - *features* documentation changed. - - From: Stephen J Bevan - * t3.init: new. Fixes problems with require, substring, and - <,>,<=,>= with more than 2 arguments. - -Fri Sep 18 00:10:57 1992 Aubrey Jaffer (jaffer at Ivan) - - From andrew@astro.psu.edu Wed Sep 16 17:58:21 1992 - * dynamic.scm: added. - - From raible@nas.nasa.gov Thu Sep 17 22:28:25 1992 - * fluidlet.scm: added. - -Sun Sep 13 23:08:46 1992 Aubrey Jaffer (jaffer at Ivan) - - * sc-macro.scm (macro:repl): moved (require 'debug) into syntax-error. - - * dynwind.scm, withfile.scm, trnscrpt.scm: created. - - From kend@data.rain.com Sun Sep 13 21:26:59 1992 - * collect.scm: created. - * oop.scm => yasos.scm: updated. - * oop.doc: removed. - - From: Stephen J. Bevan 19920912 - * elk.init: created - -Tue Jul 14 11:42:57 1992 Aubrey Jaffer (jaffer at Ivan) - - * tek41.scm tek40.scm: added. - -Tue Jul 7 00:55:58 1992 Aubrey Jaffer (jaffer at Ivan) - - * record.scm record.doc (record-sub-predicate): added. - - * sc-macro.scm (macro:repl): syntax-errors now return into - macro:repl. - - * debug.scm (qp): removed (newline). Added qpn (qp with newline). - -Sun Jun 14 22:57:32 1992 Aubrey Jaffer (jaffer at Ivan) - - * slib1b8 released. - -Sat Jun 13 17:01:41 1992 Aubrey Jaffer (jaffer at Ivan) - - * alist.scm ppfile.scm: added. - - * hash.scm hashtab.scm scheme48.init: added. - - * sc-macro.scm (macro:repl): created. macro:load now uses - eval:eval!. - - * eval.scm (eval:eval!) created and eval done in terms of it. - - * prime.scm (prime:prime?) fixed misplaced parenthesis. - -Wed May 27 16:13:17 1992 Aubrey Jaffer (jaffer at Ivan) - - From: "Chris Hanson" - * synrul.scm (generate-match): fixed for CASE syntax. - -Wed May 20 00:25:40 1992 Aubrey Jaffer (jaffer at Ivan) - - * slib1b6 released. - - * Template.scm gambit.init mitscheme.init scheme2c.init: - rearranged *features*. - -Tue May 19 22:51:28 1992 Aubrey Jaffer (jaffer at Ivan) - - * scmactst.scm: test cases fixed. - - From: "Chris Hanson" - * r4syn.scm (make-r4rs-primitive-macrology): TRANSFORMER added - back in. - - * require.scm (load): load now passes through additional - arguments to *old-load*. - -Mon May 18 00:59:36 1992 Aubrey Jaffer (jaffer at Ivan) - - * mulapply.scm (apply): written. - - * record.scm record.doc (make-record-sub-type): added. - -Fri May 8 17:55:14 1992 Aubrey Jaffer (jaffer at Ivan) - - * process.scm: created, but not finished. - - From: hugh@ear.mit.edu (Hugh Secker-Walker) - * comlist.scm (nreverse make-list): non-recursive versions added. - - * sc2.scm (1+ -1+): versions which capture +. - - * mularg.scm (- /): created. - -Wed Apr 8 00:05:30 1992 Aubrey Jaffer (jaffer at Ivan) - - * require.scm sc-macro.scm (catalog): Now uses macro:load if - 'macro is part of catalog entry. - - From: Andrew Wilcox (awilcox@astro.psu.edu) - * queue.scm: created. - -Sun Mar 15 12:23:06 1992 Aubrey Jaffer (jaffer at Ivan) - - * comlist.scm (notevery): fixed. Now (not (every ..)). - - * eval.scm (eval:eval): renamed to slib:eval. - - * record.scm: replaced with version from From: david carlton - . I changed updater => modifier, put - record-predicate into the rtd, and bummed code mercilessly. - - From: plogan@std.mentor.com (Patrick Logan) - * sc3.scm (last-pair): changed from testing null? to pair?. diff --git a/module/slib/DrScheme.init b/module/slib/DrScheme.init deleted file mode 100644 index 067625091..000000000 --- a/module/slib/DrScheme.init +++ /dev/null @@ -1,6 +0,0 @@ -;;;"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/module/slib/FAQ b/module/slib/FAQ deleted file mode 100644 index 8b8a63648..000000000 --- a/module/slib/FAQ +++ /dev/null @@ -1,217 +0,0 @@ -FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib2d1). -Written by Aubrey Jaffer (http://swissnet.ai.mit.edu/~jaffer). - - INTRODUCTION AND GENERAL INFORMATION - -[] What is SLIB? - -SLIB is a portable scheme library meant to provide compatibiliy and -utility functions for all standard scheme implementations. - -[] What is Scheme? - -Scheme is a programming language in the Lisp family. - -[] Which implementations has SLIB been ported to? - -SLIB is supported by Bigloo, Chez, DrScheme, ELK, GAMBIT, MacScheme, -MITScheme, PocketScheme, RScheme Scheme->C, Scheme48, SCM, SCSH, T3.1, -UMB-Scheme, and VSCM. - -[] How can I obtain SLIB? - -SLIB is available via http from: - http://swissnet.ai.mit.edu/~jaffer/SLIB.html -SLIB is available via ftp from: - swissnet.ai.mit.edu:/pub/scm/ - -SLIB is also included with SCM floppy disks. - -[] How do I install SLIB? - -Read the INSTALLATION INSTRUCTIONS in "slib/README". - -[] What are slib.texi and slib.info? - -"slib.texi" is the `texinfo' format documentation for SLIB. -"slib.info" is produced from "slib.texi" by either Gnu Emacs or the -program `makeinfo'. "slib.info" can be viewed using either Gnu Emacs -or `info' or a text editor. - -Programs for printing and viewing TexInfo documentation (which SLIB -has) come with GNU Emacs or can be obtained via ftp from: - ftp.gnu.org:/pub/gnu/texinfo/texinfo-3.12.tar.gz - -[] How often is SLIB released? - -Several times a year. - -[] What is the latest version? - -The version as of this writing is slib2d1. The latest documentation -is available online at: - http://swissnet.ai.mit.edu/~jaffer/SLIB.html - -[] Which version am I using? - -The Version is in the first line of the files slib/FAQ, slib/ANNOUNCE, -and slib/README. If you have Scheme and SLIB running, type -(slib:report-version) - - SLIB INSTALLATION PROBLEMS - -[] When I load an SLIB initialization file for my Scheme - implementation, I get ERROR: Couldn't find "require.scm" - -Did you remember to set either the environment variable -SCHEME_LIBRARY_PATH or the library-vicinity in your initialization -file to the correct location? If you set SCHEME_LIBRARY_PATH, make -sure that the Scheme implementation supports getenv. - -[] When I load an SLIB initialization file for my Scheme - implementation, I get ERROR: Couldn't find - "/usr/local/lib/slibrequire.scm" - -Notice that it is looking for "slibrequire.scm" rather than -"slib/require.scm". You need to put a trailing slash on either the -environment variable SCHEME_LIBRARY_PATH or in the library-vicinity in -your initialization file. - -[] SLIB used to work, but now I get ERROR: Couldn't find - "slib/require.scm". What happened? - -You changed directories and now the relative pathname -"slib/require.scm" no longer refers to the same directory. The -environment variable SCHEME_LIBRARY_PATH and library-vicinity in your -initialization file should be absolute pathnames. - -[] When I type (require 'macro) I get "ERROR: unbound variable: - require". - -You need to arrange to have your Scheme implementation load the -appropriate SLIB initialization file ("foo.init") before using SLIB. -If your implementation loads an initialization file on startup, you -can have it load the SLIB initialization file automatically. For -example (load "/usr/local/lib/slib/foo.init"). - -[] Why do I get a string-ref (or other) error when I try to load - or use SLIB. - -Check that the version of the Scheme implementation you are using -matches the version for which the SLIB initialization file was -written. There are some notes in the SLIB initialization files about -earlier versions. You may need to get a more recent version of your -Scheme implementation. - - USING SLIB PROCEDURES - -[] I installed SLIB. When I type (random 5) I get "ERROR: - unbound variable: random". Doesn't SLIB have a `random' - function? - -Before you can use most SLIB functions, the associated module needs to -be loaded. You do this by typing the line that appears at the top of -the page in slib.info (or slib.texi) where the function is documented. -In the case of random, that line is (require 'random). - -[] Why doesn't SLIB just load all the functions so I don't have - to type require statements? - -SLIB has more than 1 Megabyte of Scheme source code. Many scheme -implementations take unacceptably long to load 1 Megabyte of source; -some implementations cannot allocate enough storage. If you use a -package often, you can put the require statement in your Scheme -initialization file. Consult the manual for your Scheme -implementation to find out the initialization file's name. - -`Autoloads' will work with many Scheme implementations. You could put -the following in your initialization file: - (define (random . args) (require 'random) (apply random args)) - -I find that I only type require statements at top level when -debugging. I put require statements in my Scheme files so that the -appropriate modules are loaded automatically. - -[] Why does SLIB have PRINTF when it already has the more - powerful (CommonLisp) FORMAT? - -CommonLisp FORMAT does not support essential features which PRINTF -does. For instance, how do you format a signed 0 extended number? - - (format t "~8,'0,X~%" -3) ==> 000000-3 - -But printf gets it right: - - (printf "%08x\n" -3) ==> -0000003 - -How can one trunctate a non-numeric field using FORMAT? This feature -is essential for printing reports. The first 20 letters of a name is -sufficient to identify it. But if that name doesn't get trucated to -the desired length it can displace other fields off the page. Once -again, printf gets it right: - - (printf "%.20s\n" "the quick brown fox jumped over the lazy dog") - ==> the quick brown fox - -FORMAT also lacks directives for formatting date and time. printf -does not handle these directly, but a related function strftime does. - -[] Why doesn't SLIB:ERROR call FORMAT? - -Format does not provide a method to truncate fields. When an error -message contains non-terminating or large expressions, the essential -information of the message may be lost in the ensuing deluge. - -FORMAT as currently written in SLIB is not reentrant. Until this is -fixed, exception handlers and errors which might occur while using -FORMAT cannot use it. - - MACROS - -[] Why are there so many macro implementations in SLIB? - -The R4RS committee specified only the high level pattern language in -the Revised^4 Report on Scheme and left to the free marketplace of -ideas the details of the low-level facility. Each macro package has a -different low-level facility. The low-level facilities are sometimes -needed because the high level pattern language is insufficiently -powerful to accomplish tasks macros are often written to do. - -[] Why are there both R4RS macros and Common-Lisp style defmacros - in SLIB? - -Most Scheme implementations predate the adoption of the R4RS macro -specification. All of the implementations except scheme48 version -0.45 support defmacro natively. - -[] I did (LOAD "slib/yasos.scm"). The error I get is "variable - define-syntax is undefined". - -The way to load the struct macro package is (REQUIRE 'YASOS). - -[] I did (REQUIRE 'YASOS). Now when I type (DEFINE-PREDICATE - CELL?) The error I get is "variable define-predicate is - undefined". - -If your Scheme does not natively support R4RS macros, you will need to -install a macro-capable read-eval-print loop. This is done by: - (require 'macro) ;already done if you did (require 'yasos) - (require 'repl) - (repl:top-level macro:eval) - -This would also be true for a Scheme implementation which didn't -support DEFMACRO. The lines in this case would be: - (require 'repl) - (repl:top-level defmacro:eval) - -[] I always use R4RS macros with an implementation which doesn't - natively support them. How can I avoid having to type require - statements every time I start Scheme? - -As explained in the Repl entry in slib.info (or slib.texi): - - To have your top level loop always use macros, add any interrupt - catching code and the following script to your Scheme init file: - (require 'macro) - (require 'repl) - (repl:top-level macro:eval) diff --git a/module/slib/Makefile b/module/slib/Makefile deleted file mode 100644 index 023e0ef55..000000000 --- a/module/slib/Makefile +++ /dev/null @@ -1,333 +0,0 @@ -# Makefile for Scheme Library -# Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 Aubrey Jaffer. - -SHELL = /bin/sh -intro: - @echo - @echo "Welcome to SLIB. Read \"README\" and \"slib.info\" (or" - @echo "\"slib.texi\") to learn how to install and use SLIB." - @echo - @echo - -make slib.info - -srcdir=$(HOME)/slib/ -PREVDOCS = slib/ -dvidir=../dvi/ -dvi: $(dvidir)slib.dvi -$(dvidir)slib.dvi: version.txi slib.texi $(dvidir)slib.fn schmooz.texi -# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)slib.texi - -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex slib.??) - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi -$(dvidir)slib.fn: - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi \ - $(srcdir)schmooz.texi -xdvi: $(dvidir)slib.dvi - xdvi -s 6 $(dvidir)slib.dvi -htmldir=../public_html/ -slib_toc.html: version.txi slib.texi htmlform.txi schmooz.texi - texi2html -split -verbose slib.texi - -$(PREVDOCS)slib_toc.html: - cd slib;make slib_toc.html - cd slib;texi2html -split -verbose slib.texi - -html: $(htmldir)slib_toc.html -$(htmldir)slib_toc.html: slib slib_toc.html Makefile - hitch $(PREVDOCS)slib_\*.html slib_\*.html $(htmldir) - -rpm_prefix=/usr/src/redhat/ - -prefix = /usr/local -exec_prefix = $(prefix) -bindir = $(exec_prefix)/bin -libdir = $(exec_prefix)/lib -infodir = $(exec_prefix)/info -RUNNABLE = scheme48 -LIB = $(libdir)/$(RUNNABLE) -VM = scheme48vm -IMAGE = slib.image -INSTALL_DATA = install -c - -slib48.036: - (echo ,load `pwd`/scheme48.init; \ - echo "(define *args* '())"; \ - echo "(define (program-arguments) (cons \"$(VM)\" *args*))"; \ - echo ,dump $(LIB)/$(IMAGE); \ - echo ,exit) | scheme48 - (echo '#!/bin/sh'; \ - echo exec '$(LIB)/$(VM)' -i '$(LIB)/$(IMAGE)' \"\$$\@\") \ - > $(bindir)/slib48 - chmod +x $(bindir)/slib48 - -$(LIB)/slibcat: - touch $(LIB)/slibcat - -slib48: $(LIB)/slibcat Makefile - (echo ",batch on"; \ - echo ",config"; \ - echo ",load =scheme48/misc/packages.scm"; \ - echo "(define-structure slib-primitives"; \ - echo " (export s48-error"; \ - echo " s48-ascii->char"; \ - echo " s48-force-output"; \ - echo " s48-current-error-port"; \ - echo " s48-system";\ - echo " s48-with-handler";\ - echo " s48-getenv)";\ - echo " (open scheme signals ascii extended-ports i/o"; \ - echo " primitives handle unix-getenv)"; \ - echo " (begin"; \ - echo " (define s48-error error)"; \ - echo " (define s48-ascii->char ascii->char)"; \ - echo " (define s48-force-output force-output)"; \ - echo " (define s48-current-error-port current-error-port)"; \ - echo " (define (s48-system c) (vm-extension 96 c))"; \ - echo " (define s48-with-handler with-handler)"; \ - echo " (define s48-getenv getenv)))"; \ - echo ",user"; \ - echo ",open slib-primitives"; \ - echo "(define (implementation-vicinity) \"$(LIB)/\")"; \ - echo "(define (library-vicinity) \"`pwd`/\")"; \ - echo ",load scheme48.init"; \ - echo "(define *args* '())"; \ - echo "(define (program-arguments) (cons \"scheme48\" *args*))"; \ - echo "(set! *catalog* #f)"; \ - echo ",collect"; \ - echo ",batch off"; \ - echo ",dump $(IMAGE) \"(slib $(VERSION))\""; \ - echo ",exit") | scheme48 - -install48: slib48 - $(INSTALL_DATA) $(IMAGE) $(LIB) - (echo '#!/bin/sh'; \ - echo exec $(RUNNABLE) -i '$(LIB)/$(IMAGE)' \"\$$\@\") \ - > $(bindir)/slib48 - chmod +x $(bindir)/slib48 - -#### Stuff for maintaining SLIB below #### - -VERSION = 2d1 -ver = $(VERSION) -version.txi: Makefile - echo @set SLIBVERSION $(VERSION) > version.txi - echo @set SLIBDATE `date +"%B %Y"` >> version.txi - -scheme = scm - -htmlform.txi: *.scm - $(scheme) -rschmooz -e'(schmooz "slib.texi")' -slib.info: version.txi slib.texi htmlform.txi objdoc.txi schmooz.texi - makeinfo slib.texi --no-split -o slib.info - mv slib.info slib$(VERSION).info - if [ -f $(PREVDOCS)slib.info ]; \ - then infobar $(PREVDOCS)slib.info slib$(VERSION).info slib.info; \ - else cp slib$(VERSION).info slib.info;fi -info: installinfo -installinfo: $(infodir)/slib.info -$(infodir)/slib.info: slib.info - cp -a slib.info $(infodir)/slib.info - -install-info $(infodir)/slib.info $(infodir)/dir - -rm $(infodir)/slib.info.gz -infoz: installinfoz -installinfoz: $(infodir)/slib.info.gz -$(infodir)/slib.info.gz: $(infodir)/slib.info - gzip -f $(infodir)/slib.info - -ffiles = printf.scm format.scm genwrite.scm obj2str.scm pp.scm \ - ppfile.scm strcase.scm debug.scm trace.scm lineio.scm \ - strport.scm scanf.scm chap.scm qp.scm break.scm stdio.scm \ - strsrch.scm prec.scm schmooz.scm -lfiles = sort.scm comlist.scm tree.scm logical.scm random.scm tsort.scm \ - coerce.scm -revfiles = sc4opt.scm sc4sc3.scm sc2.scm mularg.scm mulapply.scm \ - trnscrpt.scm withfile.scm dynwind.scm promise.scm values.scm \ - eval.scm -afiles = ratize.scm randinex.scm modular.scm factor.scm \ - charplot.scm root.scm minimize.scm cring.scm determ.scm \ - selfset.scm psxtime.scm cltime.scm timezone.scm tzfile.scm -bfiles = collect.scm fluidlet.scm struct.scm object.scm recobj.scm yasyn.scm -scfiles = r4rsyn.scm scmacro.scm synclo.scm synrul.scm synchk.scm \ - repl.scm macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm -scafiles = scainit.scm scaglob.scm scamacr.scm scaoutp.scm scaexpp.scm \ - structure.scm -dfiles = defmacex.scm mbe.scm -efiles = record.scm dynamic.scm queue.scm process.scm \ - priorque.scm hash.scm hashtab.scm alist.scm \ - wttree.scm wttest.scm array.scm arraymap.scm \ - sierpinski.scm soundex.scm byte.scm nclients.scm pnm.scm \ - simetrix.scm -rfiles = rdms.scm alistab.scm dbutil.scm paramlst.scm report.scm \ - batch.scm makcrc.scm dbrowse.scm comparse.scm getopt.scm \ - htmlform.scm db2html.scm http-cgi.scm getparam.scm glob.scm \ - fft.scm uri.scm -gfiles = tek40.scm tek41.scm -docfiles = ANNOUNCE README FAQ slib.info slib.texi schmooz.texi ChangeLog \ - coerce.txi lineio.txi nclients.txi factor.txi minimize.txi \ - obj2str.txi randinex.txi random.txi uri.txi db2html.txi \ - htmlform.txi http-cgi.txi version.txi fmtdoc.txi objdoc.txi -mfiles = Makefile require.scm Template.scm syncase.sh mklibcat.scm \ - Bev2slib.scm slib.spec -ifiles = bigloo.init chez.init elk.init macscheme.init \ - mitscheme.init scheme2c.init scheme48.init gambit.init t3.init \ - vscm.init mitcomp.pat scm.init scsh.init pscheme.init STk.init \ - RScheme.init DrScheme.init umbscheme.init -tfiles = plottest.scm formatst.scm macrotst.scm scmactst.scm \ - dwindtst.scm structst.scm -sfiles = $(ffiles) $(lfiles) $(revfiles) $(afiles) $(scfiles) $(efiles) \ - $(rfiles) $(gfiles) $(scafiles) $(dfiles) -allfiles = $(docfiles) $(mfiles) $(ifiles) $(sfiles) $(tfiles) $(bfiles) - -makedev = make -f $(HOME)/makefile.dev -CHPAT=$(HOME)/bin/chpat -RSYNC=rsync -avessh -dest = $(HOME)/dist/ -temp/slib: $(allfiles) - -rm -rf temp - mkdir temp - mkdir temp/slib - ln $(allfiles) temp/slib - -infotemp/slib: slib.info - -rm -rf infotemp - mkdir infotemp - mkdir infotemp/slib - ln slib.info slib.info-* infotemp/slib -#For change-barred HTML. -slib: - unzip -a $(dest)slib[0-9]*.zip - -distinfo: $(dest)slib.info.zip -$(dest)slib.info.zip: infotemp/slib - $(makedev) TEMP=infotemp/ DEST=$(dest) PROD=slib ver=.info zip - rm -rf infotemp - -release: dist rpm - cvs tag -F slib$(VERSION) - cp ANNOUNCE $(htmldir)SLIB_ANNOUNCE.txt - $(RSYNC) $(htmldir)SLIB.html $(htmldir)SLIB_ANNOUNCE.txt nestle.ai.mit.edu:public_html/ - $(RSYNC) $(dest)README $(dest)slib$(VERSION).zip \ - $(dest)slib-$(VERSION)-1.noarch.rpm nestle.ai.mit.edu:dist/ -# upload $(dest)README $(dest)slib$(VERSION).zip ftp.gnu.org:gnu/jacal/ -# $(MAKE) indiana -indiana: - upload $(dest)slib$(VERSION).zip ftp@ftp.cs.indiana.edu:/pub/scheme-repository/incoming - echo -e \ - 'I have uploaded slib$(VERSION).zip to ftp.cs.indiana.edu:/pub/scheme-repository/incoming\n' \ - 'for placement into ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/' \ - | mail -s 'SLIB upload' -b jaffer scheme-repository-request@cs.indiana.edu - -postnews: - echo -e "Newsgroups: comp.lang.scheme\n" | cat - ANNOUNCE | \ - inews -h -O -S \ - -f "announce@docupress.com (Aubrey Jaffer & Radey Shouman)" \ - -t "SLIB$(VERSION) Released" -d world - -upzip: $(HOME)/pub/slib.zip - $(RSYNC) $(HOME)/pub/slib.zip nestle.ai.mit.edu:pub/ - -dist: $(dest)slib$(VERSION).zip -$(dest)slib$(VERSION).zip: temp/slib - $(makedev) DEST=$(dest) PROD=slib ver=$(VERSION) zip - -rpm: $(dest)slib-$(VERSION)-1.noarch.rpm -$(dest)slib-$(VERSION)-1.noarch.rpm: $(dest)slib$(VERSION).zip - cp $(dest)slib$(VERSION).zip $(rpm_prefix)SOURCES - rpm -bb --clean slib.spec - rm $(rpm_prefix)SOURCES/slib$(VERSION).zip - mv $(rpm_prefix)RPMS/noarch/slib-$(VERSION)-1.noarch.rpm $(dest) - -shar: slib.shar -slib.shar: temp/slib - $(makedev) PROD=slib shar -dclshar: slib.com -com: slib.com -slib.com: temp/slib - $(makedev) PROD=slib com -zip: slib.zip -slib.zip: temp/slib - $(makedev) PROD=slib zip -doszip: /c/scm/dist/slib$(VERSION).zip -/c/scm/dist/slib$(VERSION).zip: temp/slib - $(makedev) DEST=/c/scm/dist/ PROD=slib ver=$(VERSION) zip - zip -d /c/scm/dist/slib$(VERSION).zip slib/slib.info -pubzip: temp/slib - $(makedev) DEST=$(HOME)/pub/ PROD=slib zip - -diffs: pubdiffs -pubdiffs: temp/slib - $(makedev) DEST=$(HOME)/pub/ PROD=slib pubdiffs -distdiffs: temp/slib - $(makedev) DEST=$(dest) PROD=slib ver=$(ver) distdiffs -announcediffs: temp/slib - $(makedev) DEST=$(dest) PROD=slib ver=$(VERSION) announcediffs - -psdfiles=COPYING.psd README.psd cmuscheme.el comint.el instrum.scm pexpr.scm \ - primitives.scm psd-slib.scm psd.el read.scm runtime.scm version.scm -psdocfiles=article.bbl article.tex manual.bbl manual.tex quick-intro.tex - -psdtemp/slib: - -rm -rf psdtemp - mkdir psdtemp - mkdir psdtemp/slib - mkdir psdtemp/slib/psd - cd psd; ln $(psdfiles) ../psdtemp/slib/psd - mkdir psdtemp/slib/psd/doc - cd psd/doc; ln $(psdocfiles) ../../psdtemp/slib/psd/doc - -psdist: $(dest)slib-psd.tar.gz -$(dest)slib-psd.tar.gz: psdtemp/slib - $(makedev) DEST=$(dest) PROD=slib ver=-psd tar.gz TEMP=psdtemp/ - -new: - echo `date` \ Aubrey Jaffer \ \<`whoami`@`hostname`\>> change - echo>> change - echo \ \* require.scm \(*SLIB-VERSION*\): Bumped from $(VERSION) to $(ver).>>change - echo>> change - cat ChangeLog >> change - mv -f change ChangeLog - $(CHPAT) slib$(VERSION) slib$(ver) ANNOUNCE FAQ ../scm/ANNOUNCE \ - ../jacal/ANNOUNCE ../wb/README ../wb/ANNOUNCE \ - ../synch/ANNOUNCE \ - $(htmldir)README.html ../dist/README \ - $(htmldir)JACAL.html \ - $(htmldir)SCM.html $(htmldir)Hobbit.html \ - $(htmldir)SIMSYNCH.html ../scm/scm.texi \ - /c/scm/dist/install.bat /c/scm/dist/makefile \ - /c/scm/dist/mkdisk.bat - $(CHPAT) slib-$(VERSION) slib-$(ver) ANNOUNCE FAQ ../scm/ANNOUNCE \ - ../jacal/ANNOUNCE ../wb/README ../wb/ANNOUNCE \ - ../synch/ANNOUNCE \ - $(htmldir)README.html ../dist/README \ - $(htmldir)JACAL.html \ - $(htmldir)SCM.html $(htmldir)Hobbit.html \ - $(htmldir)SIMSYNCH.html ../scm/scm.texi \ - /c/scm/dist/install.bat /c/scm/dist/makefile \ - /c/scm/dist/mkdisk.bat - $(CHPAT) $(VERSION) $(ver) README slib.texi require.scm Makefile \ - $(htmldir)SLIB.html slib.spec - cvs commit -m '(*SLIB-VERSION*): Bumped from $(VERSION) to $(ver).' - cvs tag -F slib$(ver) - -tagfiles = version.txi slib.texi $(mfiles) $(sfiles) $(bfiles) $(tfiles) \ - $(ifiles) -# README and $(ifiles) cause semgentation faults in ETAGS for Emacs version 19. -tags: $(tagfiles) - etags $(tagfiles) -test: $(sfiles) - scheme Template.scm $(sfiles) -rights: - scm -ladmin -e"(admin:check-all)" $(sfiles) $(tfiles) \ - $(bfiles) $(ifiles) -report: - scmlit -e"(slib:report #t)" - scm -e"(slib:report #t)" -clean: - -rm -f *~ *.bak *.orig *.rej core a.out *.o \#* - -rm -rf *temp -distclean: realclean -realclean: - -rm -f *~ *.bak *.orig *.rej TAGS core a.out *.o \#* - -rm -f slib.info* slib.?? slib.??? - -rm -rf *temp -realempty: temp/slib - -rm -f $(allfiles) diff --git a/module/slib/README b/module/slib/README deleted file mode 100644 index 4b55b610c..000000000 --- a/module/slib/README +++ /dev/null @@ -1,297 +0,0 @@ -This directory contains the distribution of Scheme Library slib2d1. -Slib conforms to Revised^5 Report on the Algorithmic Language Scheme -and the IEEE P1178 specification. Slib supports Unix and similar -systems, VMS, and MS-DOS. - -The maintainer can be reached at jaffer @ ai.mit.edu. - http://swissnet.ai.mit.edu/~jaffer/SLIB.html - - MANIFEST - - `README' is this file. It contains a MANIFEST, INSTALLATION - INSTRUCTIONS, and coding guidelines. - `FAQ' Frequently Asked Questions and answers. - `ChangeLog' documents changes to slib. - `slib.texi' has documentation on library packages in TexInfo format. - - `Template.scm' Example configuration file. Copy and customize to - reflect your system. - `bigloo.init' is a configuration file for Bigloo. - `chez.init' is a configuration file for Chez Scheme. - `DrScheme.init' is a configuration file for DrScheme. - `elk.init' is a configuration file for ELK 2.1 - `gambit.init' is a configuration file for Gambit Scheme. - `macscheme.init' is a configuration file for MacScheme. - `mitscheme.init' is a configuration file for MIT Scheme. - `mitcomp.pat' is a patch file which adds definitions to SLIB files - for the MitScheme compiler. - `pscheme.init' is configuration file for PocketScheme 0.2.5 (WinCE SIOD) - `RScheme.init' is a configuration file for RScheme. - `scheme2c.init' is a configuration file for DEC's scheme->c. - `scheme48.init' is a configuration file for Scheme48. - `scsh.init' is a configuration file for Scheme-Shell - `scm.init' is a configuration file for SCM. - `t3.init' is a configuration file for T3.1 in Scheme mode. - `STk.init' is a configuration file for STk. - `umbscheme.init' is a configuration file for umb-scheme. - `vscm.init' is a configuration file for VSCM. - `mklibcat.scm' builds the *catalog* cache. - `require.scm' has code which allows system independent access to - the library files. - - `Bev2slib.scm' Converts Stephen Bevan's "*.map" files to SLIB catalog entries. - `format.scm' has Common-Lisp style format. - `formatst.scm' has code to test format.scm - `pp.scm' has pretty-print. - `ppfile.scm' has pprint-file and pprint-filter-file. - `obj2str.scm' has object->string. - `strcase.scm' has functions for manipulating the case of strings. - `genwrite.scm' has a generic-write which is used by pp.scm, - pp2str.scm and obj2str.scm - `printf.scm' has printf, fprintf, and sprintf compatible with C. - `scanf.scm' has scanf, fscanf, and sscanf compatible by C. - `lineio' has line oriented input/output functions. - `qp.scm' has printer safe for circular structures. - `break.scm' has break and continue. - `trace.scm' has trace and untrace for tracing function execution. - `debug.scm' has handy higher level debugging aids. - `strport.scm' has routines for string-ports. - `strsrch.scm' search for chars or substrings in strings and ports. - - `alist.scm' has functions accessing and modifying association lists. - `hash.scm' defines hash, hashq, and hashv. - `hashtab.scm' has hash tables. - `sierpinski.scm' 2-dimensional coordinate hash. - `soundex.scm' English name hash. - `logical.scm' emulates 2's complement logical operations. - `random.scm' has random number generator compatible with Common Lisp. - `randinex.scm' has inexact real number distributions. - `primes.scm' has primes and probably-prime?. - `factor.scm' has factor. - `root.scm' has Newton's and Laguerre's methods for finding roots. - `minimize.scm' has Golden Section Search for minimum value. - `cring.scm' extend + and * to custom commutative rings. - `selfset.scm' sets single letter identifiers to their symbols. - `determ.scm' compute determinant of list of lists. - `charplot.scm' has procedure for plotting on character screens. - `plottest.scm' has code to test charplot.scm. - `tek40.scm' has routines for Tektronix 4000 series graphics. - `tek41.scm' has routines for Tektronix 4100 series graphics. - `getopt.scm' has posix-like getopt for parsing command line arguments. - `psxtime.scm' has Posix time conversion routines. - `cltime.scm' has Common-Lisp time conversion routines. - `timezone.scm' has the default time-zone, UTC. - `tzfile.scm' reads sysV style (binary) timezone file. - `comparse.scm' has shell-like command parsing. - - `rdms.scm' has code to construct a relational database from a base - table implementation. - `alistab.scm' has association list base tables. - `dbutil.scm' has utilities for creating and manipulating relational - databases. - `htmlform.scm' generates HTML-3.2 with forms. - `db2html.scm' convert relational database to hyperlinked tables and - pages. - `http-cgi.scm' serves WWW pages with HTTP or CGI. - `uri.scm' encodes and decodes Uniform Resource Identifiers. - `dbrowse.scm' browses relational databases. - `paramlst.scm' has procedures for passing parameters by name. - `getparam.scm' has procedures for converting getopt to parameters. - `report.scm' prints database reports. - `schmooz.scm' is a simple, lightweight markup language for - interspersing Texinfo documentation with Scheme source code. - `glob.scm' has filename matching and manipulation. - `batch.scm' Group and execute commands on various operating systems. - `makcrc.scm' Create Scheme procedure to calculate POSIX.2 checksums - or other CRCs. - - `record.scm' a MITScheme user-definable datatypes package - `promise.scm' has code from R4RS for supporting DELAY and FORCE. - - `repl.scm' has a read-eval-print-loop. - `defmacex.scm' has defmacro:expand*. - `mbe.scm' has "Macro by Example" define-syntax. - `scmacro.scm' is a syntactic closure R4RS macro package. - r4rsyn.scm, synclo.scm, synrul.scm have syntax definitions - and support. - `scmactst.scm' is code for testing SYNTACTIC CLOSURE macros. - `scainit.scm' is a syntax-case R4RS macro package. - scaglob.scm scamacr.scm scaoutp.scm scaexpp.scm have - syntax definitions and support. `syncase.sh' is a shell - script for producing the SLIB version from the original. - `macwork.scm' is a "Macros that work" package. - mwexpand.scm mwdenote.scm mwsynrul.scm have support. - `macrotst.scm' is code from R4RS for testing macros. - - `values.scm' is multiple values. - `queue.scm' has queues and stacks. - - `object.scm' is an object system. - `yasyn.scm' defines (syntax-rules) macros for object oriented programming. - `collect.scm' is collection operators (like CL sequences). - `priorque.scm' has code and documentation for priority queues. - `wttree.scm' has weight-balanced trees. - `wttest.scm' tests weight-balanced trees. - `process.scm' has multi-processing primitives. - `array.scm' has multi-dimensional arrays and sub-arrays. - `arraymap.scm' has array-map!, array-for-each, and array-indexes. - - `sort.scm' has sorted?, sort, sort!, merge, and merge!. - `tsort.scm' has topological-sort. - `comlist.scm' has many common list and mapping procedures. - `tree.scm' has functions dealing with trees. - `coerce.scm' has coerce and type-of from Common-Lisp. - `chap.scm' has functions which compare and create strings in - "chapter order". - - `sc4opt.scm' has optional rev4 procedures. - `sc4sc3.scm' has procedures to make a rev3 implementation run rev4 - code. - `sc2.scm' has rev2 procedures eliminated in subsequent versions. - `mularg.scm' redefines - and / to take more than 2 arguments. - `mulapply.scm' redefines apply to take more than 2 arguments. - `ratize.scm' has function rationalize from Revised^4 spec. - `trnscrpt.scm' has transcript-on and transcript-off from Revised^4 spec. - `withfile.scm' has with-input-from-file and with-output-to-file from R4RS. - `dynwind.scm' has dynamic-wind from R5RS. - `eval.scm' has eval with environments from R5RS. - `dwindtst.scm' has routines for characterizing dynamic-wind. - `dynamic.scm' has DYNAMIC data type [obsolete]. - `fluidlet.scm' has fluid-let syntax. - `struct.scm' has defmacros which implement RECORDS from the book: - "Essentials of Programming Languages". - `structure.scm' has syntax-case macros for the same. - `structst.scm' has test code for struct.scm. - `byte.scm' has arrays of small integers. - `nclients.scm' provides a Scheme interface to FTP and WWW Browsers. - `pnm.scm' provides a Scheme interface to "portable bitmap" files. - `simetrix.scm' provides SI Metric Interchange Format. - - INSTALLATION INSTRUCTIONS - - Check the manifest in `README' to find a configuration file for your -Scheme implementation. Initialization files for most IEEE P1178 -compliant Scheme Implementations are included with this distribution. - - If the Scheme implementation supports `getenv', then the value of the -shell environment variable SCHEME_LIBRARY_PATH will be used for -`(library-vicinity)' if it is defined. Currently, Chez, Elk, -MITScheme, scheme->c, VSCM, and SCM support `getenv'. Scheme48 -supports `getenv' but does not use it for determining -`library-vicinity'. (That is done from the Makefile.) - - You should check the definitions of `software-type', -`scheme-implementation-version', `implementation-vicinity', and -`library-vicinity' in the initialization file. There are comments in -the file for how to configure it. - - Once this is done you can modify the startup file for your Scheme -implementation to `load' this initialization file. SLIB is then -installed. - - Multiple implementations of Scheme can all use the same SLIB -directory. Simply configure each implementation's initialization file -as outlined above. - - - Implementation: SCM - The SCM implementation does not require any initialization file as - SLIB support is already built into SCM. See the documentation - with SCM for installation instructions. - - - Implementation: VSCM - From: Matthias Blume - 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 - Date: Mon, 2 Oct 2000 21:29:48 -0400 (EDT) - From: Shriram Krishnamurthi - - We distribute an SLIB init file for our system. If you have PLT - Scheme (our preferred name for the entire suite, which includes - DrScheme, MzScheme and other implementations) installed, you ought - to be able to run "help-desk", or run `drscheme' and choose Help - Desk from the Help menu; in Help Desk, type `slib'. This will give - instructions for how to load the SLIB init file. - - PORTING INSTRUCTIONS - - If there is no initialization file for your Scheme implementation, you -will have to create one. Your Scheme implementation must be largely -compliant with - `IEEE Std 1178-1990', - `Revised(4) Report on the Algorithmic Language Scheme', or - `Revised(5) Report on the Algorithmic Language Scheme' -in order to support SLIB. - - `Template.scm' is an example configuration file. The comments inside -will direct you on how to customize it to reflect your system. Give -your new initialization file the implementation's name with `.init' -appended. For instance, if you were porting `foo-scheme' then the -initialization file might be called `foo.init'. - - Your customized version should then be loaded as part of your scheme -implementation's initialization. It will load `require.scm' from the -library; this will allow the use of `provide', `provided?', and -`require' along with the "vicinity" functions. The rest of the -library will then be accessible in a system independent fashion. - - Please mail new working configuration files to `jaffer@ai.mit.edu' so -that they can be included in the SLIB distribution. - - CODING GUIDELINES - - All library packages are written in IEEE P1178 Scheme and assume that -a configuration file and `require.scm' package have already been -loaded. Other versions of Scheme can be supported in library packages -as well by using, for example, `(provided? 'rev3-report)' or `(require -'rev3-report)'. - - `require.scm' defines `*catalog*', an association list of module -names and filenames. When a new package is added to the library, an -entry should be added to `require.scm'. Local packages can also be -added to `*catalog*' and even shadow entries already in the table. - - The module name and `:' should prefix each symbol defined in the -package. Definitions for external use should then be exported by having -`(define foo module-name:foo)'. - - Submitted packages should not duplicate routines which are already in -SLIB files. Use `require' to force those features to be supported in -your package. Care should be taken that there are no circularities in -the `require's and `load's between the library packages. - - Documentation should be provided in Emacs Texinfo format if possible, -But documentation must be provided. diff --git a/module/slib/RScheme.init b/module/slib/RScheme.init deleted file mode 100644 index 15b89b300..000000000 --- a/module/slib/RScheme.init +++ /dev/null @@ -1,290 +0,0 @@ -;;;"RScheme.init" Initialization for SLIB for RScheme -*-scheme-*- -;;;; From http://www.rscheme.org/rs/pg1/RScheme.scm -;;; Author: Aubrey Jaffer -;;; -;;; This code is in the public domain. -;;; -;;; adapted for RScheme by Donovan Kolbly -- (v1 1997-09-14) -;;; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;; (software-type) should be set to the generic operating system type. -;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - -(define (software-type) 'UNIX) - -;;; (scheme-implementation-type) should return the name of the scheme -;;; implementation loading this file. - -(define (scheme-implementation-type) 'RScheme) - -;;; (scheme-implementation-home-page) should return a (string) URI -;;; (Uniform Resource Identifier) for this scheme implementation's home -;;; page; or false if there isn't one. - -(define (scheme-implementation-home-page) "http://www.rscheme.org/") - -;;; (scheme-implementation-version) should return a string describing -;;; the version the scheme implementation loading this file. - -(define (scheme-implementation-version) "0.7.1") - -;;; (implementation-vicinity) should be defined to be the pathname of -;;; the directory where any auxillary files to your Scheme -;;; implementation reside. - -(define (implementation-vicinity) - (case (software-type) - ((UNIX) "/usr/local/lib/rs/0.7.1/") - ((VMS) "scheme$src:") - ((MS-DOS) "C:\\scheme\\"))) - -;;; (library-vicinity) should be defined to be the pathname of the -;;; directory where files of Scheme library functions reside. - -(define library-vicinity - (let ((library-path - (or - ;; Use this getenv if your implementation supports it. - (getenv "SCHEME_LIBRARY_PATH") - ;; Use this path if your scheme does not support GETENV - ;; or if SCHEME_LIBRARY_PATH is not set. - (case (software-type) - ((UNIX) "/usr/lib/slib/") - ((VMS) "lib$scheme:") - ((MS-DOS) "C:\\SLIB\\") - (else ""))))) - (lambda () library-path))) - -;;; *FEATURES* should be set to a list of symbols describing features -;;; of this implementation. Suggestions for features are: - -(define *features* - '( - source ;can load scheme source files - ;(slib:load-source "filename") -; compiled ;can load compiled files - ;(slib:load-compiled "filename") - rev4-report ;conforms to -; rev3-report ;conforms to -; ieee-p1178 ;conforms to -; sicp ;runs code from Structure and - ;Interpretation of Computer - ;Programs by Abelson and Sussman. - rev4-optional-procedures ;LIST-TAIL, STRING->LIST, - ;LIST->STRING, STRING-COPY, - ;STRING-FILL!, LIST->VECTOR, - ;VECTOR->LIST, and VECTOR-FILL! -; rev2-procedures ;SUBSTRING-MOVE-LEFT!, - ;SUBSTRING-MOVE-RIGHT!, - ;SUBSTRING-FILL!, - ;STRING-NULL?, APPEND!, 1+, - ;-1+, ?, >=? - multiarg/and- ;/ and - can take more than 2 args. - multiarg-apply ;APPLY can take more than 2 args. -; rationalize - delay ;has DELAY and FORCE - with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE - string-port ;has CALL-WITH-INPUT-STRING and - ;CALL-WITH-OUTPUT-STRING -; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF - char-ready? -; macro ;has R4RS high level macros -; defmacro ;has Common Lisp DEFMACRO -; eval ;SLIB:EVAL is single argument eval -; record ;has user defined data structures -; values ;proposed multiple values -; dynamic-wind ;proposed dynamic-wind -; ieee-floating-point ;conforms to - full-continuation ;can return multiple times -; object-hash ;has OBJECT-HASH - -; sort -; queue ;queues -; pretty-print -; object->string -; format -; trace ;has macros: TRACE and UNTRACE -; compiler ;has (COMPILER) -; ed ;(ED) is editor -; system ;posix (system ) - 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 - )) - -;;; (OUTPUT-PORT-WIDTH ) -(define (output-port-width . arg) 79) - -;;; (OUTPUT-PORT-HEIGHT ) -(define (output-port-height . arg) 24) - -;;; (CURRENT-ERROR-PORT) -;(define current-error-port -; (let ((port (current-output-port))) -; (lambda () port))) - -;;; (TMPNAM) makes a temporary file name. -(define tmpnam (let ((cntr 100)) - (lambda () (set! cntr (+ 1 cntr)) - (string-append "slib_" (number->string cntr))))) - -;;; (FILE-EXISTS? ) -(define (file-exists? f) (os-file-exists? f)) - -;;; (DELETE-FILE ) -(define (delete-file f) #f) - -;;; FORCE-OUTPUT flushes any pending output on optional arg output port -;;; use this definition if your system doesn't have such a procedure. -(define (force-output . arg) - (flush-output-port (if (null? arg) - (current-output-port) - (car arg)))) - -;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string -;;; port versions of CALL-WITH-*PUT-FILE. - -;;; CHAR-CODE-LIMIT is one greater than the largest integer which can -;;; be returned by CHAR->INTEGER. -(define char-code-limit 65536) - -;;; MOST-POSITIVE-FIXNUM is used in modular.scm -(define most-positive-fixnum #x1FFFFFFF) - -;;; Return argument -;;(define (identity x) x) - -;;; If your implementation provides eval SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. -(define slib:eval eval) - -;;; If your implementation provides R4RS macros: -;(define macro:eval slib:eval) -;(define macro:load load) - -(define *defmacros* - (list (cons 'defmacro - (lambda (name parms . body) - `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) - *defmacros*)))))) -(define (defmacro? m) (and (assq m *defmacros*) #t)) - -(define (macroexpand-1 e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) (set! a (assq a *defmacros*)) - (if a (apply (cdr a) (cdr e)) e)) - (else e))) - e)) - -(define (macroexpand e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) - (set! a (assq a *defmacros*)) - (if a (macroexpand (apply (cdr a) (cdr e))) e)) - (else e))) - e)) - -(define gentemp - (let ((*gensym-counter* -1)) - (lambda () - (set! *gensym-counter* (+ *gensym-counter* 1)) - (string->symbol - (string-append "slib:G" (number->string *gensym-counter*)))))) - -(define base:eval slib:eval) -(define (defmacro:eval x) (base:eval (defmacro:expand* x))) -(define (defmacro:expand* x) - (require 'defmacroexpand) (apply defmacro:expand* x '())) - -(define (defmacro:load ) - (slib:eval-load defmacro:eval)) - -(define (slib:eval-load evl) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (call-with-input-file - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* ) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - -(define slib:warn - (lambda args - (let ((cep (current-error-port))) - (if (provided? 'trace) (print-call-stack cep)) - (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) - -;;; define an error procedure for the library -(define (slib:error msg . args) - (if (provided? 'trace) (print-call-stack (current-error-port))) - (error "~a ~j" msg args)) - -;;; define these as appropriate for your system. -(define slib:tab (integer->char 9)) -(define slib:form-feed (integer->char 12)) - -;;; Support for older versions of Scheme. Not enough code for its own file. -;(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) -(define t #t) -(define nil #f) - -;;; Define these if your implementation's syntax can support it and if -;;; they are not already defined. - -;(define (1+ n) (+ n 1)) -;(define (-1+ n) (+ n -1)) -;(define 1- -1+) - -(define in-vicinity string-append) - -;;; Define SLIB:EXIT to be the implementation procedure to exit or -;;; return if exitting not supported. -(define slib:exit (lambda args (process-exit 0))) - -;;; Here for backward compatability -(define scheme-file-suffix - (let ((suffix (case (software-type) - ((NOSVE) "_scm") - (else ".scm")))) - (lambda () suffix))) - -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever -;;; suffix all the module files in SLIB have. See feature 'SOURCE. - -(define (slib:load-source f) (load (string-append f ".scm"))) - -;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced -;;; by compiling "foo.scm" if this implementation can compile files. -;;; See feature 'COMPILED. - -(define slib:load-compiled load) - -;;; At this point SLIB:LOAD must be able to load SLIB files. - -(define slib:load slib:load-source) - -(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/module/slib/STk.init b/module/slib/STk.init deleted file mode 100644 index 26ab01c61..000000000 --- a/module/slib/STk.init +++ /dev/null @@ -1,256 +0,0 @@ -;;;"STk.init" SLIB Initialization for STk -*-scheme-*- -;;; Authors: Erick Gallesio (eg@unice.fr) and Aubrey Jaffer. -;;; -;;; This code is in the public domain. - -(require "unix") - -;;; (software-type) should be set to the generic operating system type. -;;; UNIX, VMS, MACOS, AMIGA and MSDOS are supported. - -(define (software-type) 'UNIX) - -;;; (scheme-implementation-type) should return the name of the scheme -;;; implementation loading this file. - -(define (scheme-implementation-type) '|STk|) - -;;; (scheme-implementation-home-page) should return a (string) URI -;;; (Uniform Resource Identifier) for this scheme implementation's home -;;; page; or false if there isn't one. - -(define (scheme-implementation-home-page) - "http://kaolin.unice.fr/STk/STk.html") - -;;; (scheme-implementation-version) should return a string describing -;;; the version the scheme implementation loading this file. - -(define (scheme-implementation-version) (version)) - -;;; (implementation-vicinity) should be defined to be the pathname of -;;; the directory where any auxillary files to your Scheme -;;; implementation reside. - -(define (implementation-vicinity) "/usr/local/lib/stk/3.99.3/") - -;;; (library-vicinity) should be defined to be the pathname of the -;;; directory where files of Scheme library functions reside. - -(define library-vicinity - (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH") "/usr/local/lib/slib/"))) - (lambda () library-path))) - -;;; -;;; -(define home-vicinity - (let ((home-path (or (getenv "HOME") "/"))) - (lambda () home-path))) - -;;; *FEATURES* should be set to a list of symbols describing features -;;; of this implementation. Suggestions for features are: - -(define *features* - '( - source ;can load scheme source files - ;(slib:load-source "filename") - compiled ;can load compiled files - ;(slib:load-compiled "filename") - rev4-report ;conforms to -; rev3-report ;conforms to -; ieee-p1178 ;conforms to -; sicp ;runs code from Structure and - ;Interpretation of Computer - ;Programs by Abelson and Sussman. - rev4-optional-procedures ;LIST-TAIL, STRING->LIST, - ;LIST->STRING, STRING-COPY, - ;STRING-FILL!, LIST->VECTOR, - ;VECTOR->LIST, and VECTOR-FILL! -; rev3-procedures ;LAST-PAIR, T, and NIL -; rev2-procedures ;SUBSTRING-MOVE-LEFT!, - ;SUBSTRING-MOVE-RIGHT!, - ;SUBSTRING-FILL!, - ;STRING-NULL?, APPEND!, 1+, - ;-1+, ?, >=? - multiarg/and- ;/ and - can take more than 2 args. - multiarg-apply ;APPLY can take more than 2 args. -; rationalize - delay ;has DELAY and FORCE - with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE - string-port ;has CALL-WITH-INPUT-STRING and - ;CALL-WITH-OUTPUT-STRING -; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF -; char-ready? -; macro ;has R4RS high level macros -; defmacro ;has Common Lisp DEFMACRO - eval ;SLIB:EVAL is single argument eval -; record ;has user defined data structures -; values ;proposed multiple values - dynamic-wind ;proposed dynamic-wind - ieee-floating-point ;conforms to - full-continuation ;can return multiple times -; object-hash ;has OBJECT-HASH - -; sort ; commented because icomplete -; queue ;queues -; pretty-print -; object->string -; format -; compiler ;has (COMPILER) - ed ;(ED) is editor - system ;posix (system ) - 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 - )) - -;;; (OUTPUT-PORT-WIDTH ) -(define (output-port-width . arg) 79) - -;;; (OUTPUT-PORT-HEIGHT ) -(define (output-port-height . arg) 24) - -;;; (TMPNAM) makes a temporary file name. -(define tmpnam (let ((cntr 100)) - (lambda () (set! cntr (+ 1 cntr)) - (string-append "slib_" (number->string cntr))))) - -;;; (DELETE-FILE ) -(define (delete-file f) (system (format #f "/bin/rm ~A" f))) - -;;; FORCE-OUTPUT flushes any pending output on optional arg output port -;;; use this definition if your system doesn't have such a procedure. -(define (force-output . arg) (apply flush arg)) - -;;; CHAR-CODE-LIMIT is one greater than the largest integer which can -;;; be returned by CHAR->INTEGER. -(define char-code-limit 256) - -;;; MOST-POSITIVE-FIXNUM is used in modular.scm -(define most-positive-fixnum #x0fffffff) - -;;; If your implementation provides eval SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. -(define slib:eval eval) - -;;; If your implementation provides R4RS macros: -;(define macro:eval slib:eval) -;(define macro:load load) - -(define *macros* '()) - -(define-macro (defmacro name args . body) - `(begin - (define-macro (,name ,@args) ,@body) - (set! *macros* (cons ,name *macros*)))) - - -(define (defmacro? m) (and (memv m *macros*) #t)) - -(define macroexpand-1 MACRO-EXPAND-1) -(define macroexpand MACRO-EXPAND) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define gentemp GENSYM) -(define base:eval slib:eval) - -(define (defmacro:eval x) (base:eval (defmacro:expand* x))) -(define (defmacro:expand* x) - (require 'defmacroexpand) (apply defmacro:expand* x '())) - -(define (defmacro:load ) - (slib:eval-load defmacro:eval)) - -(define (slib:eval-load evl) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (call-with-input-file - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* ) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - -(define slib:warn - (lambda args - (let ((cep (current-error-port))) - (if (provided? 'trace) (print-call-stack cep)) - (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) - -;;; define an error procedure for the library -(define (slib:error . args) - (if (provided? 'trace) (print-call-stack (current-error-port))) - (error (apply string-append (map (lambda (x) (format #f " ~a" x)) args)))) - - -;;; define these as appropriate for your system. -(define slib:tab (integer->char 9)) -(define slib:form-feed (integer->char 12)) - -;;; Define these if your implementation's syntax can support it and if -;;; they are not already defined. -(define -1+ 1-) - -(define in-vicinity string-append) - -;;; Define SLIB:EXIT to be the implementation procedure to exit or -;;; return if exitting not supported. -(define slib:exit exit) - -;;; Here for backward compatability -(define scheme-file-suffix - (let ((suffix (case (software-type) - ((NOSVE) "_scm") - (else ".scm")))) - (lambda () suffix))) - -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever -;;; suffix all the module files in SLIB have. See feature 'SOURCE. - -(define slib:load-source LOAD) - -;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced -;;; by compiling "foo.scm" if this implementation can compile files. -;;; See feature 'COMPILED. - -(define slib:load-compiled load) - -;;; -;;; Retain original require/provide before loading "require.scm" -;;; -(define stk:require require) -(define stk:provide provide) -(define stk:provided? provided?) - -(define slib:load slib:load-source) -(slib:load (in-vicinity (library-vicinity) "require")) - - -;;; -;;; Redefine require/provide so that symbols use SLIB one and strings use STk one -;;; - -(define require - (let ((slib:require require)) - (lambda (item) - ((if (symbol? item) slib:require stk:require) item )))) - -(define provide - (let ((slib:provide provide)) - (lambda (item) - ((if (symbol? item) slib:provide stk:provide) item)))) - -(define provided? - (let ((slib:provided? provided?)) - (lambda (item) - ((if (symbol? item) slib:provided? stk:provided?) item)))) - -(define identity (lambda (x) x)) diff --git a/module/slib/Template.scm b/module/slib/Template.scm deleted file mode 100644 index aa8862718..000000000 --- a/module/slib/Template.scm +++ /dev/null @@ -1,282 +0,0 @@ -;;; "Template.scm" configuration template of *features* for Scheme -*-scheme-*- -;;; Author: Aubrey Jaffer -;;; -;;; This code is in the public domain. - -;;; (software-type) should be set to the generic operating system type. -;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - -(define (software-type) 'UNIX) - -;;; (scheme-implementation-type) should return the name of the scheme -;;; implementation loading this file. - -(define (scheme-implementation-type) 'Template) - -;;; (scheme-implementation-home-page) should return a (string) URI -;;; (Uniform Resource Identifier) for this scheme implementation's home -;;; page; or false if there isn't one. - -(define (scheme-implementation-home-page) #f) - -;;; (scheme-implementation-version) should return a string describing -;;; the version the scheme implementation loading this file. - -(define (scheme-implementation-version) "?") - -;;; (implementation-vicinity) should be defined to be the pathname of -;;; the directory where any auxillary files to your Scheme -;;; implementation reside. - -(define (implementation-vicinity) - (case (software-type) - ((UNIX) "/usr/local/src/scheme/") - ((VMS) "scheme$src:") - ((MS-DOS) "C:\\scheme\\"))) - -;;; (library-vicinity) should be defined to be the pathname of the -;;; directory where files of Scheme library functions reside. - -(define library-vicinity - (let ((library-path - (or - ;; Use this getenv if your implementation supports it. - (getenv "SCHEME_LIBRARY_PATH") - ;; Use this path if your scheme does not support GETENV - ;; or if SCHEME_LIBRARY_PATH is not set. - (case (software-type) - ((UNIX) "/usr/local/lib/slib/") - ((VMS) "lib$scheme:") - ((MS-DOS) "C:\\SLIB\\") - (else ""))))) - (lambda () library-path))) - -;;; (home-vicinity) should return the vicinity of the user's HOME -;;; directory, the directory which typically contains files which -;;; customize a computer environment for a user. - -(define home-vicinity - (let ((home-path (getenv "HOME"))) - (lambda () home-path))) - -;;; *FEATURES* should be set to a list of symbols describing features -;;; of this implementation. Suggestions for features are: - -(define *features* - '( - source ;can load scheme source files - ;(slib:load-source "filename") -; compiled ;can load compiled files - ;(slib:load-compiled "filename") -; rev4-report ;conforms to -; rev3-report ;conforms to -; ieee-p1178 ;conforms to -; sicp ;runs code from Structure and - ;Interpretation of Computer - ;Programs by Abelson and Sussman. -; rev4-optional-procedures ;LIST-TAIL, STRING->LIST, - ;LIST->STRING, STRING-COPY, - ;STRING-FILL!, LIST->VECTOR, - ;VECTOR->LIST, and VECTOR-FILL! -; rev2-procedures ;SUBSTRING-MOVE-LEFT!, - ;SUBSTRING-MOVE-RIGHT!, - ;SUBSTRING-FILL!, - ;STRING-NULL?, APPEND!, 1+, - ;-1+, ?, >=? -; multiarg/and- ;/ and - can take more than 2 args. -; multiarg-apply ;APPLY can take more than 2 args. -; rationalize -; delay ;has DELAY and FORCE -; with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE -; string-port ;has CALL-WITH-INPUT-STRING and - ;CALL-WITH-OUTPUT-STRING -; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF -; char-ready? -; macro ;has R4RS high level macros -; defmacro ;has Common Lisp DEFMACRO -; eval ;R5RS two-argument eval -; record ;has user defined data structures -; values ;proposed multiple values -; dynamic-wind ;proposed dynamic-wind -; ieee-floating-point ;conforms to - full-continuation ;can return multiple times -; object-hash ;has OBJECT-HASH - -; sort -; queue ;queues -; pretty-print -; object->string -; format -; trace ;has macros: TRACE and UNTRACE -; compiler ;has (COMPILER) -; ed ;(ED) is editor -; system ;posix (system ) - 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 - )) - -;;; (OUTPUT-PORT-WIDTH ) -(define (output-port-width . arg) 79) - -;;; (OUTPUT-PORT-HEIGHT ) -(define (output-port-height . arg) 24) - -;;; (CURRENT-ERROR-PORT) -(define current-error-port - (let ((port (current-output-port))) - (lambda () port))) - -;;; (TMPNAM) makes a temporary file name. -(define tmpnam (let ((cntr 100)) - (lambda () (set! cntr (+ 1 cntr)) - (string-append "slib_" (number->string cntr))))) - -;;; (FILE-EXISTS? ) -(define (file-exists? f) #f) - -;;; (DELETE-FILE ) -(define (delete-file f) #f) - -;;; FORCE-OUTPUT flushes any pending output on optional arg output port -;;; use this definition if your system doesn't have such a procedure. -(define (force-output . arg) #t) - -;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string -;;; port versions of CALL-WITH-*PUT-FILE. - -;;; "rationalize" adjunct procedures. -;;(define (find-ratio x e) -;; (let ((rat (rationalize x e))) -;; (list (numerator rat) (denominator rat)))) -;;(define (find-ratio-between x y) -;; (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) - -;;; CHAR-CODE-LIMIT is one greater than the largest integer which can -;;; be returned by CHAR->INTEGER. -(define char-code-limit 256) - -;;; MOST-POSITIVE-FIXNUM is used in modular.scm -(define most-positive-fixnum #x0FFFFFFF) - -;;; Return argument -(define (identity x) x) - -;;; SLIB:EVAL is single argument eval using the top-level (user) environment. -(define slib:eval eval) - -;;; If your implementation provides R4RS macros: -;(define macro:eval slib:eval) -;(define macro:load load) - -(define *defmacros* - (list (cons 'defmacro - (lambda (name parms . body) - `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) - *defmacros*)))))) -(define (defmacro? m) (and (assq m *defmacros*) #t)) - -(define (macroexpand-1 e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) (set! a (assq a *defmacros*)) - (if a (apply (cdr a) (cdr e)) e)) - (else e))) - e)) - -(define (macroexpand e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) - (set! a (assq a *defmacros*)) - (if a (macroexpand (apply (cdr a) (cdr e))) e)) - (else e))) - e)) - -(define gentemp - (let ((*gensym-counter* -1)) - (lambda () - (set! *gensym-counter* (+ *gensym-counter* 1)) - (string->symbol - (string-append "slib:G" (number->string *gensym-counter*)))))) - -(define base:eval slib:eval) -(define (defmacro:eval x) (base:eval (defmacro:expand* x))) -(define (defmacro:expand* x) - (require 'defmacroexpand) (apply defmacro:expand* x '())) - -(define (slib:eval-load evl) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (call-with-input-file - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* ) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - -(define (defmacro:load ) - (slib:eval-load defmacro:eval)) - -(define slib:warn - (lambda args - (let ((cep (current-error-port))) - (if (provided? 'trace) (print-call-stack cep)) - (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) - -;;; define an error procedure for the library -(define (slib:error . args) - (if (provided? 'trace) (print-call-stack (current-error-port))) - (apply error args)) - -;;; define these as appropriate for your system. -(define slib:tab (integer->char 9)) -(define slib:form-feed (integer->char 12)) - -;;; Support for older versions of Scheme. Not enough code for its own file. -(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) -(define t #t) -(define nil #f) - -;;; Define these if your implementation's syntax can support it and if -;;; they are not already defined. - -;(define (1+ n) (+ n 1)) -;(define (-1+ n) (+ n -1)) -;(define 1- -1+) - -(define in-vicinity string-append) - -;;; Define SLIB:EXIT to be the implementation procedure to exit or -;;; return if exitting not supported. -(define slib:exit (lambda args #f)) - -;;; Here for backward compatability -(define scheme-file-suffix - (let ((suffix (case (software-type) - ((NOSVE) "_scm") - (else ".scm")))) - (lambda () suffix))) - -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever -;;; suffix all the module files in SLIB have. See feature 'SOURCE. - -(define (slib:load-source f) (load (string-append f ".scm"))) - -;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced -;;; by compiling "foo.scm" if this implementation can compile files. -;;; See feature 'COMPILED. - -(define slib:load-compiled load) - -;;; At this point SLIB:LOAD must be able to load SLIB files. - -(define slib:load slib:load-source) - -(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/module/slib/alist.scm b/module/slib/alist.scm deleted file mode 100644 index 65ddb220c..000000000 --- a/module/slib/alist.scm +++ /dev/null @@ -1,66 +0,0 @@ -;;;"alist.scm", alist functions for Scheme. -;;;Copyright (c) 1992, 1993 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(define (predicate->asso pred) - (cond ((eq? eq? pred) assq) - ((eq? = pred) assv) - ((eq? eqv? pred) assv) - ((eq? char=? pred) assv) - ((eq? equal? pred) assoc) - ((eq? string=? pred) assoc) - (else (lambda (key alist) - (let l ((al alist)) - (cond ((null? al) #f) - ((pred key (caar al)) (car al)) - (else (l (cdr al))))))))) - -(define (alist-inquirer pred) - (let ((assofun (predicate->asso pred))) - (lambda (alist key) - (let ((pair (assofun key alist))) - (and pair (cdr pair)))))) - -(define (alist-associator pred) - (let ((assofun (predicate->asso pred))) - (lambda (alist key val) - (let* ((pair (assofun key alist))) - (cond (pair (set-cdr! pair val) - alist) - (else (cons (cons key val) alist))))))) - -(define (alist-remover pred) - (lambda (alist key) - (cond ((null? alist) alist) - ((pred key (caar alist)) (cdr alist)) - ((null? (cdr alist)) alist) - ((pred key (caadr alist)) - (set-cdr! alist (cddr alist)) alist) - (else - (let l ((al (cdr alist))) - (cond ((null? (cdr al)) alist) - ((pred key (caadr al)) - (set-cdr! al (cddr al)) alist) - (else (l (cdr al))))))))) - -(define (alist-map proc alist) - (map (lambda (pair) (cons (car pair) (proc (car pair) (cdr pair)))) - alist)) - -(define (alist-for-each proc alist) - (for-each (lambda (pair) (proc (car pair) (cdr pair))) alist)) diff --git a/module/slib/alistab.scm b/module/slib/alistab.scm deleted file mode 100644 index 395bf0678..000000000 --- a/module/slib/alistab.scm +++ /dev/null @@ -1,352 +0,0 @@ -;;; "alistab.scm" database tables using association lists (assoc) -; Copyright 1994, 1997 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;; LLDB is (filename . alist-table) -;;; HANDLE is (#(table-name key-dim) . TABLE) -;;; TABLE is an alist of (Primary-key . ROW) -;;; ROW is a list of non-primary VALUEs - -(require 'common-list-functions) - -(define alist-table - (let ((catalog-id 0) - (resources '*base-resources*) - (make-list-keyifier (lambda (prinum types) identity)) - (make-keyifier-1 (lambda (type) list)) - (make-key->list (lambda (prinum types) identity)) - (make-key-extractor (lambda (primary-limit column-type-list index) - (let ((i (+ -1 index))) - (lambda (lst) (list-ref lst i)))))) - -(define keyify-1 (make-keyifier-1 'atom)) - -(define (make-base filename dim types) - (list filename - (list catalog-id) - (list resources (list 'free-id 1)))) - -(define (open-base infile writable) - (and (or (input-port? infile) (file-exists? infile)) - (cons (if (input-port? infile) #f infile) - ((lambda (fun) - (if (input-port? infile) - (fun infile) - (call-with-input-file infile fun))) - read)))) - -(define (write-base lldb outfile) - ((lambda (fun) - (cond ((output-port? outfile) (fun outfile)) - ((string? outfile) (call-with-output-file outfile fun)) - (else #f))) - (lambda (port) - (display (string-append - ";;; \"" outfile "\" SLIB alist-table database -*-scheme-*-") - port) - (newline port) (newline port) - (display "(" port) (newline port) - (for-each - (lambda (table) - (display " (" port) - (write (car table) port) (newline port) - (for-each - (lambda (row) - (display " " port) (write row port) (newline port)) - (cdr table)) - (display " )" port) (newline port)) - (cdr lldb)) - (display ")" port) (newline port) -; (require 'pretty-print) -; (pretty-print (cdr lldb) port) - (set-car! lldb (if (string? outfile) outfile #f)) - #t))) - -(define (sync-base lldb) - (cond ((car lldb) (write-base lldb (car lldb)) #t) - (else -;;; (display "sync-base: database filename not known") - #f))) - -(define (close-base lldb) - (cond ((car lldb) (write-base lldb (car lldb)) - (set-cdr! lldb #f) - (set-car! lldb #f) #t) - ((cdr lldb) (set-cdr! lldb #f) - (set-car! lldb #f) #t) - (else -;;; (display "close-base: database not open") - #f))) - -(define (make-table lldb dim types) - (let ((free-hand (open-table lldb resources 1 '(atom integer)))) - (and free-hand - (let* ((row (assoc* (keyify-1 'free-id) (handle->alist free-hand))) - (table-id #f)) - (cond (row - (set! table-id (cadr row)) - (set-car! (cdr row) (+ 1 table-id)) - (set-cdr! lldb (cons (list table-id) (cdr lldb))) - table-id) - (else #f)))))) - -(define (open-table lldb base-id dim types) - (assoc base-id (cdr lldb))) - -(define (kill-table lldb base-id dim types) - (define ckey (list base-id)) - (let ((pair (assoc* ckey (cdr lldb)))) - (and pair (set-cdr! lldb (delete-assoc ckey (cdr lldb)))) - (and pair (not (assoc* ckey (cdr lldb)))))) - -(define handle->alist cdr) -(define set-handle-alist! set-cdr!) - -(define (assoc* keys alist) - (let ((pair (assoc (car keys) alist))) - (cond ((not pair) #f) - ((null? (cdr keys)) pair) - (else (assoc* (cdr keys) (cdr pair)))))) - -(define (make-assoc* keys alist vals) - (let ((pair (assoc (car keys) alist))) - (cond ((not pair) (cons (cons (car keys) - (if (null? (cdr keys)) - vals - (make-assoc* (cdr keys) '() vals))) - alist)) - (else (set-cdr! pair (if (null? (cdr keys)) - vals - (make-assoc* (cdr keys) (cdr pair) vals))) - alist)))) - -(define (delete-assoc ckey alist) - (cond - ((null? ckey) '()) - ((assoc (car ckey) alist) - => (lambda (match) - (let ((adl (delete-assoc (cdr ckey) (cdr match)))) - (cond ((null? adl) (delete match alist)) - (else (set-cdr! match adl) alist))))) - (else alist))) - -(define (delete-assoc* ckey alist) - (cond - ((every not ckey) '()) ;includes the null case. - ((not (car ckey)) - (delete '() - (map (lambda (fodder) - (let ((adl (delete-assoc* (cdr ckey) (cdr fodder)))) - (if (null? adl) '() (cons (car fodder) adl)))) - alist))) - ((procedure? (car ckey)) - (delete '() - (map (lambda (fodder) - (if ((car ckey) (car fodder)) - (let ((adl (delete-assoc* (cdr ckey) (cdr fodder)))) - (if (null? adl) '() (cons (car fodder) adl))) - fodder)) - alist))) - ((assoc (car ckey) alist) - => (lambda (match) - (let ((adl (delete-assoc* (cdr ckey) (cdr match)))) - (cond ((null? adl) (delete match alist)) - (else (set-cdr! match adl) alist))))) - (else alist))) - -(define (assoc*-for-each proc bkey ckey alist) - (cond ((null? ckey) (proc (reverse bkey))) - ((not (car ckey)) - (for-each (lambda (alist) - (assoc*-for-each proc - (cons (car alist) bkey) - (cdr ckey) - (cdr alist))) - alist)) - ((procedure? (car ckey)) - (for-each (lambda (alist) - (if ((car ckey) (car alist)) - (assoc*-for-each proc - (cons (car alist) bkey) - (cdr ckey) - (cdr alist)))) - alist)) - ((assoc (car ckey) alist) - => (lambda (match) - (assoc*-for-each proc - (cons (car match) bkey) - (cdr ckey) - (cdr match)))))) - -(define (assoc*-map proc bkey ckey alist) - (cond ((null? ckey) (list (proc (reverse bkey)))) - ((not (car ckey)) - (apply append - (map (lambda (alist) - (assoc*-map proc - (cons (car alist) bkey) - (cdr ckey) - (cdr alist))) - alist))) - ((procedure? (car ckey)) - (apply append - (map (lambda (alist) - (if ((car ckey) (car alist)) - (assoc*-map proc - (cons (car alist) bkey) - (cdr ckey) - (cdr alist)) - '())) - alist))) - ((assoc (car ckey) alist) - => (lambda (match) - (assoc*-map proc - (cons (car match) bkey) - (cdr ckey) - (cdr match)))) - (else '()))) - -(define (sorted-assoc*-for-each proc bkey ckey alist) - (cond ((null? ckey) (proc (reverse bkey))) - ((not (car ckey)) - (for-each (lambda (alist) - (sorted-assoc*-for-each proc - (cons (car alist) bkey) - (cdr ckey) - (cdr alist))) - (alist-sort! alist))) - ((procedure? (car ckey)) - (sorted-assoc*-for-each proc - bkey - (cons #f (cdr ckey)) - (remove-if-not (lambda (pair) - ((car ckey) (car pair))) - alist))) - ((assoc (car ckey) alist) - => (lambda (match) - (sorted-assoc*-for-each proc - (cons (car match) bkey) - (cdr ckey) - (cdr match)))))) - -(define (alist-sort! alist) - (define (key->sortable k) - (cond ((number? k) k) - ((string? k) k) - ((symbol? k) (symbol->string k)) - ((vector? k) (map key->sortable (vector->list k))) - (else (slib:error "unsortable key" k)))) - ;; This routine assumes that the car of its operands are either - ;; numbers or strings (or lists of those). - (define (car-key-< x y) - (key-< (car x) (car y))) - (define (key-< x y) - (cond ((and (number? x) (number? y)) (< x y)) - ((number? x) #t) - ((number? y) #f) - ((string? x) (stringsortable (car p)) p)) - alist) - car-key-<))) - -(define (present? handle ckey) - (assoc* ckey (handle->alist handle))) - -(define (make-putter prinum types) - (lambda (handle ckey restcols) - (set-handle-alist! handle - (make-assoc* ckey (handle->alist handle) restcols)))) - -(define (make-getter prinum types) - (lambda (handle ckey) - (let ((row (assoc* ckey (handle->alist handle)))) - (and row (cdr row))))) - -(define (for-each-key handle operation primary-limit column-type-list match-keys) - (assoc*-for-each operation - '() - match-keys - (handle->alist handle))) - -(define (map-key handle operation primary-limit column-type-list match-keys) - (assoc*-map operation - '() - match-keys - (handle->alist handle))) - -(define (ordered-for-each-key handle operation - primary-limit column-type-list match-keys) - (sorted-assoc*-for-each operation - '() - match-keys - (handle->alist handle))) - -(define (supported-type? type) - (case type - ((base-id atom integer boolean string symbol expression number) #t) - (else #f))) - -(define (supported-key-type? type) - (case type - ((atom integer number symbol string) #t) - (else #f))) - -;;make-table open-table remover assoc* make-assoc* -;;(trace assoc*-for-each assoc*-map sorted-assoc*-for-each) - - (lambda (operation-name) - (case operation-name - ((make-base) make-base) - ((open-base) open-base) - ((write-base) write-base) - ((sync-base) sync-base) - ((close-base) close-base) - ((catalog-id) catalog-id) - ((make-table) make-table) - ((open-table) open-table) - ((kill-table) kill-table) - ((make-keyifier-1) make-keyifier-1) - ((make-list-keyifier) make-list-keyifier) - ((make-key->list) make-key->list) - ((make-key-extractor) make-key-extractor) - ((supported-type?) supported-type?) - ((supported-key-type?) supported-key-type?) - ((present?) present?) - ((make-putter) make-putter) - ((make-getter) make-getter) - ((delete) - (lambda (handle ckey) - (set-handle-alist! handle - (delete-assoc ckey (handle->alist handle))))) - ((delete*) - (lambda (handle primary-limit column-type-list match-keys) - (set-handle-alist! handle - (delete-assoc* match-keys - (handle->alist handle))))) - ((for-each-key) for-each-key) - ((map-key) map-key) - ((ordered-for-each-key) ordered-for-each-key) - (else #f))) - )) - -;; #f (trace-all "/home/jaffer/slib/alistab.scm") (untrace alist-table) (set! *qp-width* 333) diff --git a/module/slib/array.scm b/module/slib/array.scm deleted file mode 100644 index 08b8114bc..000000000 --- a/module/slib/array.scm +++ /dev/null @@ -1,279 +0,0 @@ -;;;;"array.scm" Arrays for Scheme -; Copyright (C) 1993 Alan Bawden -; -; Permission to copy this software, to redistribute it, and to use it -; for any purpose is granted, subject to the following restrictions and -; understandings. -; -; 1. Any copy made of this software must include this copyright notice -; in full. -; -; 2. Users of this software agree to make their best efforts (a) to -; return to me any improvements or extensions that they make, so that -; these may be included in future releases; and (b) to inform me of -; noteworthy uses of this software. -; -; 3. I have made no warrantee or representation that the operation of -; this software will be error-free, and I am under no obligation to -; provide any services, by way of maintenance, update, or otherwise. -; -; 4. In conjunction with products arising from the use of this material, -; there shall be no use of my name in any advertising, promotional, or -; sales literature without prior written consent in each case. -; -; Alan Bawden -; MIT Room NE43-510 -; 545 Tech. Sq. -; Cambridge, MA 02139 -; Alan@LCS.MIT.EDU - -(require 'record) - -;(declare (usual-integrations)) - -(define array:rtd - (make-record-type "Array" - '(indexer ; Must be a -linear- function! - shape ; Inclusive bounds: ((lower upper) ...) - vector ; The actual contents - ))) - -(define array:indexer (record-accessor array:rtd 'indexer)) -(define array-shape (record-accessor array:rtd 'shape)) -(define array:vector (record-accessor array:rtd 'vector)) - -(define array? (record-predicate array:rtd)) - -(define (array-rank obj) - (if (array? obj) (length (array-shape obj)) 0)) - -(define (array-dimensions ra) - (map (lambda (ind) (if (zero? (car ind)) (+ 1 (cadr ind)) ind)) - (array-shape ra))) - -(define array:construct - (record-constructor array:rtd '(shape vector indexer))) - -(define (array:compute-shape specs) - (map (lambda (spec) - (cond ((and (integer? spec) - (< 0 spec)) - (list 0 (- spec 1))) - ((and (pair? spec) - (pair? (cdr spec)) - (null? (cddr spec)) - (integer? (car spec)) - (integer? (cadr spec)) - (<= (car spec) (cadr spec))) - spec) - (else (slib:error "array: Bad array dimension: " spec)))) - specs)) - -(define (make-array initial-value . specs) - (let ((shape (array:compute-shape specs))) - (let loop ((size 1) - (indexer (lambda () 0)) - (l (reverse shape))) - (if (null? l) - (array:construct shape - (make-vector size initial-value) - (array:optimize-linear-function indexer shape)) - (loop (* size (+ 1 (- (cadar l) (caar l)))) - (lambda (first-index . rest-of-indices) - (+ (* size (- first-index (caar l))) - (apply indexer rest-of-indices))) - (cdr l)))))) - -(define (make-shared-array array mapping . specs) - (let ((new-shape (array:compute-shape specs)) - (old-indexer (array:indexer array))) - (let check ((indices '()) - (bounds (reverse new-shape))) - (cond ((null? bounds) - (array:check-bounds array (apply mapping indices))) - (else - (check (cons (caar bounds) indices) (cdr bounds)) - (check (cons (cadar bounds) indices) (cdr bounds))))) - (array:construct new-shape - (array:vector array) - (array:optimize-linear-function - (lambda indices - (apply old-indexer (apply mapping indices))) - new-shape)))) - -(define (array:in-bounds? array indices) - (let loop ((indices indices) - (shape (array-shape array))) - (if (null? indices) - (null? shape) - (let ((index (car indices))) - (and (not (null? shape)) - (integer? index) - (<= (caar shape) index (cadar shape)) - (loop (cdr indices) (cdr shape))))))) - -(define (array:check-bounds array indices) - (or (array:in-bounds? array indices) - (slib:error "array: Bad indices for " array indices))) - -(define (array-ref array . indices) - (array:check-bounds array indices) - (vector-ref (array:vector array) - (apply (array:indexer array) indices))) - -(define (array-set! array new-value . indices) - (array:check-bounds array indices) - (vector-set! (array:vector array) - (apply (array:indexer array) indices) - new-value)) - -(define (array-in-bounds? array . indices) - (array:in-bounds? array indices)) - -; Fast versions of ARRAY-REF and ARRAY-SET! that do no error checking, -; and don't cons intermediate lists of indices: - -(define (array-1d-ref a i0) - (vector-ref (array:vector a) ((array:indexer a) i0))) - -(define (array-2d-ref a i0 i1) - (vector-ref (array:vector a) ((array:indexer a) i0 i1))) - -(define (array-3d-ref a i0 i1 i2) - (vector-ref (array:vector a) ((array:indexer a) i0 i1 i2))) - -(define (array-1d-set! a v i0) - (vector-set! (array:vector a) ((array:indexer a) i0) v)) - -(define (array-2d-set! a v i0 i1) - (vector-set! (array:vector a) ((array:indexer a) i0 i1) v)) - -(define (array-3d-set! a v i0 i1 i2) - (vector-set! (array:vector a) ((array:indexer a) i0 i1 i2) v)) - -; STOP! Do not read beyond this point on your first reading of -; this code -- you should simply assume that the rest of this file -; contains only the following single definition: -; -; (define (array:optimize-linear-function f l) f) -; -; Of course everything would be pretty inefficient if this were really the -; case, but it isn't. The following code takes advantage of the fact that -; you can learn everything there is to know from a linear function by -; simply probing around in its domain and observing its values -- then a -; more efficient equivalent can be constructed. - -(define (array:optimize-linear-function f l) - (let ((d (length l))) - (cond - ((= d 0) - (array:0d-c (f))) - ((= d 1) - (let ((c (f 0))) - (array:1d-c0 c (- (f 1) c)))) - ((= d 2) - (let ((c (f 0 0))) - (array:2d-c01 c (- (f 1 0) c) (- (f 0 1) c)))) - ((= d 3) - (let ((c (f 0 0 0))) - (array:3d-c012 c (- (f 1 0 0) c) (- (f 0 1 0) c) (- (f 0 0 1) c)))) - (else - (let* ((v (map (lambda (x) 0) l)) - (c (apply f v))) - (let loop ((p v) - (old-val c) - (coefs '())) - (cond ((null? p) - (array:Nd-c* c (reverse coefs))) - (else - (set-car! p 1) - (let ((new-val (apply f v))) - (loop (cdr p) - new-val - (cons (- new-val old-val) coefs))))))))))) - -; 0D cases: - -(define (array:0d-c c) - (lambda () c)) - -; 1D cases: - -(define (array:1d-c c) - (lambda (i0) (+ c i0))) - -(define (array:1d-0 n0) - (cond ((= 1 n0) +) - (else (lambda (i0) (* n0 i0))))) - -(define (array:1d-c0 c n0) - (cond ((= 0 c) (array:1d-0 n0)) - ((= 1 n0) (array:1d-c c)) - (else (lambda (i0) (+ c (* n0 i0)))))) - -; 2D cases: - -(define (array:2d-0 n0) - (lambda (i0 i1) (+ (* n0 i0) i1))) - -(define (array:2d-1 n1) - (lambda (i0 i1) (+ i0 (* n1 i1)))) - -(define (array:2d-c0 c n0) - (lambda (i0 i1) (+ c (* n0 i0) i1))) - -(define (array:2d-c1 c n1) - (lambda (i0 i1) (+ c i0 (* n1 i1)))) - -(define (array:2d-01 n0 n1) - (cond ((= 1 n0) (array:2d-1 n1)) - ((= 1 n1) (array:2d-0 n0)) - (else (lambda (i0 i1) (+ (* n0 i0) (* n1 i1)))))) - -(define (array:2d-c01 c n0 n1) - (cond ((= 0 c) (array:2d-01 n0 n1)) - ((= 1 n0) (array:2d-c1 c n1)) - ((= 1 n1) (array:2d-c0 c n0)) - (else (lambda (i0 i1) (+ c (* n0 i0) (* n1 i1)))))) - -; 3D cases: - -(define (array:3d-01 n0 n1) - (lambda (i0 i1 i2) (+ (* n0 i0) (* n1 i1) i2))) - -(define (array:3d-02 n0 n2) - (lambda (i0 i1 i2) (+ (* n0 i0) i1 (* n2 i2)))) - -(define (array:3d-12 n1 n2) - (lambda (i0 i1 i2) (+ i0 (* n1 i1) (* n2 i2)))) - -(define (array:3d-c12 c n1 n2) - (lambda (i0 i1 i2) (+ c i0 (* n1 i1) (* n2 i2)))) - -(define (array:3d-c02 c n0 n2) - (lambda (i0 i1 i2) (+ c (* n0 i0) i1 (* n2 i2)))) - -(define (array:3d-c01 c n0 n1) - (lambda (i0 i1 i2) (+ c (* n0 i0) (* n1 i1) i2))) - -(define (array:3d-012 n0 n1 n2) - (cond ((= 1 n0) (array:3d-12 n1 n2)) - ((= 1 n1) (array:3d-02 n0 n2)) - ((= 1 n2) (array:3d-01 n0 n1)) - (else (lambda (i0 i1 i2) (+ (* n0 i0) (* n1 i1) (* n2 i2)))))) - -(define (array:3d-c012 c n0 n1 n2) - (cond ((= 0 c) (array:3d-012 n0 n1 n2)) - ((= 1 n0) (array:3d-c12 c n1 n2)) - ((= 1 n1) (array:3d-c02 c n0 n2)) - ((= 1 n2) (array:3d-c01 c n0 n1)) - (else (lambda (i0 i1 i2) (+ c (* n0 i0) (* n1 i1) (* n2 i2)))))) - -; ND cases: - -(define (array:Nd-* coefs) - (lambda indices (apply + (map * coefs indices)))) - -(define (array:Nd-c* c coefs) - (cond ((= 0 c) (array:Nd-* coefs)) - (else (lambda indices (apply + c (map * coefs indices)))))) diff --git a/module/slib/arraymap.scm b/module/slib/arraymap.scm deleted file mode 100644 index ab3d7c835..000000000 --- a/module/slib/arraymap.scm +++ /dev/null @@ -1,78 +0,0 @@ -;;;; "arraymap.scm", applicative routines for arrays in Scheme. -;;; Copyright (c) 1993 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'array) - -(define (array-map! ra0 proc . ras) - (define (ramap rshape inds) - (if (null? (cdr rshape)) - (do ((i (cadar rshape) (+ -1 i)) - (is (cons (cadar rshape) inds) - (cons (+ -1 i) inds))) - ((< i (caar rshape))) - (apply array-set! ra0 - (apply proc (map (lambda (ra) (apply array-ref ra is)) - ras)) - is)) - (let ((crshape (cdr rshape)) - (ll (caar rshape))) - (do ((i (cadar rshape) (+ -1 i))) - ((< i ll)) - (ramap crshape (cons i inds)))))) - (ramap (reverse (array-shape ra0)) '())) - -(define (array-for-each proc . ras) - (define (rafe rshape inds) - (if (null? (cdr rshape)) - (do ((i (caar rshape) (+ 1 i))) - ((> i (cadar rshape))) - (apply proc - (map (lambda (ra) - (apply array-ref ra (reverse (cons i inds)))) ras))) - (let ((crshape (cdr rshape)) - (ll (cadar rshape))) - (do ((i (caar rshape) (+ 1 i))) - ((> i ll)) - (rafe crshape (cons i inds)))))) - (rafe (array-shape (car ras)) '())) - -(define (array-index-map! ra fun) - (define (ramap rshape inds) - (if (null? (cdr rshape)) - (do ((i (cadar rshape) (+ -1 i)) - (is (cons (cadar rshape) inds) - (cons (+ -1 i) inds))) - ((< i (caar rshape))) - (apply array-set! ra (apply fun is) is)) - (let ((crshape (cdr rshape)) - (ll (caar rshape))) - (do ((i (cadar rshape) (+ -1 i))) - ((< i ll)) - (ramap crshape (cons i inds)))))) - (if (zero? (array-rank ra)) - (array-set! ra (fun)) - (ramap (reverse (array-shape ra)) '()))) - -(define (array-indexes ra) - (let ((ra0 (apply make-array '() (array-shape ra)))) - (array-index-map! ra0 list) - ra0)) - -(define (array-copy! source dest) - (array-map! dest identity source)) diff --git a/module/slib/batch.scm b/module/slib/batch.scm deleted file mode 100644 index d77519dcb..000000000 --- a/module/slib/batch.scm +++ /dev/null @@ -1,454 +0,0 @@ -;;; "batch.scm" Group and execute commands on various systems. -;Copyright (C) 1994, 1995, 1997 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'line-i/o) ;Just for write-line -(require 'parameters) -(require 'database-utilities) -(require 'string-port) -(require 'tree) - -(define system - (if (provided? 'system) - system - (lambda (str) 1))) -(define system:success? - (case (software-type) - ((VMS) (lambda (int) (eqv? 1 int))) - (else zero?))) -;;(trace system system:success? exit quit slib:exit) - -(define (batch:port parms) - (let ((bp (parameter-list-ref parms 'batch-port))) - (cond ((or (not (pair? bp)) (not (output-port? (car bp)))) - (slib:warn 'batch-line "missing batch-port parameter" bp) - (current-output-port)) - (else (car bp))))) - -(define (batch:dialect parms) ; was batch-family - (car (parameter-list-ref parms 'batch-dialect))) - -(define (write-batch-line str line-limit port) - (cond ((and line-limit (>= (string-length str) line-limit)) - (slib:warn 'write-batch-line 'too-long - (string-length str) '> line-limit) - #f) - (else (write-line str port) #t))) -(define (batch-line parms str) - (write-batch-line str (batch:line-length-limit parms) (batch:port parms))) - -;;; add a Scheme batch-dialect? - -(define (batch:try-chopped-command parms . args) - (define args-but-last (batch:flatten (butlast args 1))) - (define line-limit (batch:line-length-limit parms)) - (let loop ((fodder (car (last-pair args)))) - (let ((str (batch:glued-line parms - (batch:flatten - (append args-but-last (list fodder)))))) - (cond ((< (string-length str) line-limit) - (batch:try-command parms str)) - ((< (length fodder) 2) - (slib:warn 'batch:try-chopped-command "can't fit in " line-limit - (cons proc (append args-but-last (list fodder)))) - #f) - (else (let ((hlen (quotient (length fodder) 2))) - (and (loop (last fodder hlen)) - (loop (butlast fodder hlen))))))))) - -(define (batch:glued-line parms strings) - (case (batch:dialect parms) - ((vms) (apply string-join " " "$" strings)) - ((unix dos amigados system *unknown*) (apply string-join " " strings)) - (else #f))) - -(define (batch:try-command parms . strings) - (set! strings (batch:flatten strings)) - (let ((line (batch:glued-line parms strings))) - (and line - (case (batch:dialect parms) - ((unix dos vms amigados) (batch-line parms line)) - ((system) - (let ((port (batch:port parms))) - (write `(system ,line) port) (newline port) - (and (provided? 'system) (system:success? (system line))))) - ((*unknown*) - (let ((port (batch:port parms))) - (write `(system ,line) port) (newline port) #t)) - (else #f))))) - -(define (batch:command parms . strings) - (cond ((apply batch:try-command parms strings)) - (else (slib:error 'batch:command 'failed strings)))) - -(define (batch:run-script parms name . strings) - (case (batch:dialect parms strings) - ((vms) (batch:command parms (string-append "@" name) strings)) - (else (batch:command parms name strings)))) - -(define (batch:write-comment-line dialect line port) - (case dialect - ((unix) (write-batch-line (string-append "# " line) #f port)) - ((dos) (write-batch-line (string-append "rem " line) #f port)) - ((vms) (write-batch-line (string-append "$! " line) #f port)) - ((amigados) (write-batch-line (string-append "; " line) #f port)) - ((system) (write-batch-line (string-append "; " line) #f port)) - ((*unknown*) (write-batch-line (string-append ";;; " line) #f port) - ;;(newline port) - #f))) - -(define (batch:comment parms . lines) - (define port (batch:port parms)) - (define dialect (batch:dialect parms)) - (set! lines (batch:flatten lines)) - (every (lambda (line) - (batch:write-comment-line dialect line port)) - lines)) - -(define (batch:lines->file parms file . lines) - (define port (batch:port parms)) - (set! lines (batch:flatten lines)) - (case (or (batch:dialect parms) '*unknown*) - ((unix) (batch-line parms (string-append "rm -f " file)) - (every - (lambda (string) - (batch-line parms (string-append "echo '" string "'>>" file))) - lines)) - ((dos) (batch-line parms (string-append "DEL " file)) - (every - (lambda (string) - (batch-line parms - (string-append "ECHO" (if (equal? "" string) "." " ") - string ">>" file))) - lines)) - ((vms) (and (batch-line parms (string-append "$DELETE " file)) - (batch-line parms (string-append "$CREATE " file)) - (batch-line parms (string-append "$DECK")) - (every (lambda (string) (batch-line parms string)) - lines) - (batch-line parms (string-append "$EOD")))) - ((amigados) (batch-line parms (string-append "delete force " file)) - (every - (lambda (str) - (letrec ((star-quote - (lambda (str) - (if (equal? "" str) - str - (let* ((ch (string-ref str 0)) - (s (if (char=? ch #\") - (string #\* ch) - (string ch)))) - (string-append - s - (star-quote - (substring str 1 (string-length str))))))))) - (batch-line parms (string-append "echo \"" (star-quote str) - "\" >> " file)))) - lines)) - ((system) (write `(delete-file ,file) port) (newline port) - (delete-file file) - (require 'pretty-print) - (pretty-print `(call-with-output-file ,file - (lambda (fp) - (for-each - (lambda (string) (write-line string fp)) - ',lines))) - port) - (call-with-output-file file - (lambda (fp) (for-each (lambda (string) (write-line string fp)) - lines))) - #t) - ((*unknown*) - (write `(delete-file ,file) port) (newline port) - (require 'pretty-print) - (pretty-print - `(call-with-output-file ,file - (lambda (fp) - (for-each - (lambda (string) - (write-line string fp)) - ,lines))) - port) - #f))) - -(define (batch:delete-file parms file) - (define port (batch:port parms)) - (case (batch:dialect parms) - ((unix) (batch-line parms (string-append "rm -f " file)) - #t) - ((dos) (batch-line parms (string-append "DEL " file)) - #t) - ((vms) (batch-line parms (string-append "$DELETE " file)) - #t) - ((amigados) (batch-line parms (string-append "delete force " file)) - #t) - ((system) (write `(delete-file ,file) port) (newline port) - (delete-file file)) ; SLIB provides - ((*unknown*) (write `(delete-file ,file) port) (newline port) - #f))) - -(define (batch:rename-file parms old-name new-name) - (define port (batch:port parms)) - (case (batch:dialect parms) - ((unix) (batch-line parms (string-join " " "mv -f" old-name new-name))) - ;;((dos) (batch-line parms (string-join " " "REN" old-name new-name))) - ((dos) (batch-line parms (string-join " " "MOVE" "/Y" old-name new-name))) - ((vms) (batch-line parms (string-join " " "$RENAME" old-name new-name))) - ((amigados) (batch-line parms (string-join " " "failat 21")) - (batch-line parms (string-join " " "delete force" new-name)) - (batch-line parms (string-join " " "rename" old-name new-name))) - ((system) (batch:extender 'rename-file batch:rename-file)) - ((*unknown*) (write `(rename-file ,old-name ,new-name) port) - (newline port) - #f))) - -(define (batch:write-header-comment dialect name port) - (batch:write-comment-line - dialect - (string-append (if (string? name) - (string-append "\"" name "\"") - (case dialect - ((system *unknown*) "Scheme") - ((vms) "VMS") - ((dos) "DOS") - ((default-for-platform) "??") - (else (symbol->string dialect)))) - " script created by SLIB/batch " - (cond ((provided? 'bignum) - (require 'posix-time) - (let ((ct (ctime (current-time)))) - (substring ct 0 (+ -1 (string-length ct))))) - (else ""))) - port)) - -(define (batch:call-with-output-script parms name proc) - (define dialect (batch:dialect parms)) - (case dialect - ((unix) ((cond ((and (string? name) (provided? 'system)) - (lambda (proc) - (let ((ans (call-with-output-file name proc))) - (system (string-append "chmod +x " name)) - ans))) - ((output-port? name) (lambda (proc) (proc name))) - (else (lambda (proc) (proc (current-output-port))))) - (lambda (port) - (write-line "#!/bin/sh" port) - (batch:write-header-comment dialect name port) - (proc port)))) - - ((dos) ((cond ((string? name) - (lambda (proc) - (call-with-output-file (string-append name ".bat") proc))) - ((output-port? name) (lambda (proc) (proc name))) - (else (lambda (proc) (proc (current-output-port))))) - (lambda (port) - (batch:write-header-comment dialect name port) - (proc port)))) - - ((vms) ((cond ((string? name) - (lambda (proc) - (call-with-output-file (string-append name ".COM") proc))) - ((output-port? name) (lambda (proc) (proc name))) - (else (lambda (proc) (proc (current-output-port))))) - (lambda (port) - (batch:write-header-comment dialect name port) - ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port) - (proc port)))) - - ((amigados) ((cond ((and (string? name) (provided? 'system)) - (lambda (proc) - (let ((ans (call-with-output-file name proc))) - (system (string-append "protect " name " rswd")) - ans))) - ((output-port? name) (lambda (proc) (proc name))) - (else (lambda (proc) (proc (current-output-port))))) - (lambda (port) - (batch:write-header-comment dialect name port) - (proc port)))) - - ((system) ((cond ((and (string? name) (provided? 'system)) - (lambda (proc) - (let ((ans (call-with-output-file name - (lambda (port) (proc name))))) - (system (string-append "chmod +x " name)) - ans))) - ((output-port? name) (lambda (proc) (proc name))) - (else (lambda (proc) (proc (current-output-port))))) - (lambda (port) - (batch:write-header-comment dialect name port) - (proc port)))) - - ((*unknown*) ((cond ((and (string? name) (provided? 'system)) - (lambda (proc) - (let ((ans (call-with-output-file name - (lambda (port) (proc name))))) - (system (string-append "chmod +x " name)) - ans))) - ((output-port? name) (lambda (proc) (proc name))) - (else (lambda (proc) (proc (current-output-port))))) - (lambda (port) - (batch:write-header-comment dialect name port) - (proc port)))))) - -;;; This little ditty figures out how to use a Scheme extension or -;;; SYSTEM to execute a command that is not available in the batch -;;; mode chosen. - -(define (batch:extender NAME BATCHER) - (lambda (parms . args) - (define port (batch:port parms)) - (cond - ((provided? 'i/o-extensions) ; SCM specific - (write `(,NAME ,@args) port) - (newline port) - (apply (slib:eval NAME) args)) - ((not (provided? 'system)) #f) - (else - (let ((pl (make-parameter-list (map car parms)))) - (adjoin-parameters! - pl (cons 'batch-dialect (os->batch-dialect - (parameter-list-ref parms 'platform)))) - (system - (call-with-output-string - (lambda (port) - (batch:call-with-output-script - port - (lambda (batch-port) - (define new-parms (copy-tree pl)) - (adjoin-parameters! new-parms (list 'batch-port batch-port)) - (apply BATCHER new-parms args))))))))))) - -(define (truncate-up-to str chars) - (define (tut str) - (do ((i (string-length str) (+ -1 i))) - ((or (zero? i) (memv (string-ref str (+ -1 i)) chars)) - (substring str i (string-length str))))) - (cond ((char? chars) (set! chars (list chars))) - ((string? chars) (set! chars (string->list chars)))) - (if (string? str) (tut str) (map tut str))) - -(define (must-be-first firsts lst) - (append (remove-if-not (lambda (i) (member i lst)) firsts) - (remove-if (lambda (i) (member i firsts)) lst))) - -(define (must-be-last lst lasts) - (append (remove-if (lambda (i) (member i lasts)) lst) - (remove-if-not (lambda (i) (member i lst)) lasts))) - -(define (string-join joiner . args) - (if (null? args) "" - (apply string-append - (car args) - (map (lambda (s) (string-append joiner s)) (cdr args))))) - -(define (batch:flatten strings) - (apply - append (map - (lambda (obj) - (cond ((eq? "" obj) '()) - ((string? obj) (list obj)) - ((eq? #f obj) '()) - ((null? obj) '()) - ((list? obj) (batch:flatten obj)) - (else (slib:error 'batch:flatten "unexpected type" - obj "in" strings)))) - strings))) - -(define batch:platform (software-type)) -(cond ((and (eq? 'unix batch:platform) (provided? 'system)) - (let ((file-name (tmpnam))) - (system (string-append "uname > " file-name)) - (set! batch:platform (call-with-input-file file-name read)) - (delete-file file-name)))) - -(define batch:database #f) -(define os->batch-dialect #f) -(define batch-dialect->line-length-limit #f) - -(define (batch:line-length-limit parms) - (let ((bl (parameter-list-ref parms 'batch-line-length-limit))) - (if bl (car bl) (batch-dialect->line-length-limit (batch:dialect parms))))) - -(define (batch:initialize! database) - (set! batch:database database) - (define-tables database - - '(batch-dialect - ((family atom)) - ((line-length-limit number)) - ((unix 1023) - (dos 127) - (vms 1023) - (amigados 511) - (system 1023) - (*unknown* -1))) - - '(operating-system - ((name symbol)) - ((os-family batch-dialect)) - (;;(3b1 *unknown*) - (*unknown* *unknown*) - (acorn *unknown*) - (aix unix) - (alliant *unknown*) - (amiga amigados) - (apollo unix) - (apple2 *unknown*) - (arm *unknown*) - (atari.st *unknown*) - (cdc *unknown*) - (celerity *unknown*) - (concurrent *unknown*) - (convex *unknown*) - (encore *unknown*) - (harris *unknown*) - (hp-ux unix) - (hp48 *unknown*) - (irix unix) - (isis *unknown*) - (linux unix) - (mac *unknown*) - (masscomp unix) - (mips *unknown*) - (ms-dos dos) - (ncr *unknown*) - (newton *unknown*) - (next unix) - (novell *unknown*) - (os/2 dos) - (osf1 unix) - (prime *unknown*) - (psion *unknown*) - (pyramid *unknown*) - (sequent *unknown*) - (sgi *unknown*) - (stratus *unknown*) - (sunos unix) - (transputer *unknown*) - (unicos unix) - (unix unix) - (vms vms) - ))) - - ((database 'add-domain) '(operating-system operating-system #f symbol #f)) - (set! os->batch-dialect (((batch:database 'open-table) 'operating-system #f) - 'get 'os-family)) - (set! batch-dialect->line-length-limit - (((batch:database 'open-table) 'batch-dialect #f) - 'get 'line-length-limit)) - ) diff --git a/module/slib/bigloo.init b/module/slib/bigloo.init deleted file mode 100644 index 211979b86..000000000 --- a/module/slib/bigloo.init +++ /dev/null @@ -1,263 +0,0 @@ -;; "bigloo.init" Initialization for SLIB for Bigloo -*-scheme-*- -;; Copyright 1994 Robert Sanders -;; Copyright 1991, 1992, 1993 Aubrey Jaffer -;; Copyright 1991 David Love -;; -;; Permission to copy this software, to redistribute it, and to use it -;; for any purpose is granted, subject to the following restrictions and -;; understandings. -;; -;; 1. Any copy made of this software must include this copyright notice -;; in full. -;; -;; 2. I have made no warrantee or representation that the operation of -;; this software will be error-free, and I am under no obligation to -;; provide any services, by way of maintenance, update, or otherwise. -;; -;; 3. In conjunction with products arising from the use of this -;; material, there shall be no use of my name in any advertising, -;; promotional, or sales literature without prior written consent in -;; each case. - -(define (software-type) 'UNIX) - -;;; (scheme-implementation-type) should return the name of the scheme -;;; implementation loading this file. - -(define (scheme-implementation-type) 'Bigloo) - -;;; (scheme-implementation-version) should return a string describing -;;; the version the scheme implementation loading this file. - -;;; (scheme-implementation-home-page) should return a (string) URI -;;; (Uniform Resource Identifier) for this scheme implementation's home -;;; page; or false if there isn't one. - -(define (scheme-implementation-home-page) - "http://kaolin.unice.fr/~serrano/bigloo/bigloo.html") - -(define (scheme-implementation-version) "2.0c") - -;;; (implementation-vicinity) should be defined to be the pathname of -;;; the directory where any auxillary files to your Scheme -;;; implementation reside. - -(define (implementation-vicinity) - (case (software-type) - ((UNIX) "/usr/unsup/lib/bigloo/") - ((VMS) "scheme$src:") - ((MSDOS) "C:\\scheme\\"))) - -;;; (library-vicinity) should be defined to be the pathname of the -;;; directory where files of Scheme library functions reside. - -(define library-vicinity - (let ((library-path - (or - ;; Use this getenv if your implementation supports it. - (getenv "SCHEME_LIBRARY_PATH") - ;; Use this path if your scheme does not support GETENV - ;; or if SCHEME_LIBRARY_PATH is not set. - (case (software-type) - ((UNIX) "/home/bambam/leavens/unsup-src/scheme/scm/slib/") - ((VMS) "lib$scheme:") - ((MSDOS) "C:\\SLIB\\") - (else ""))))) - (lambda () library-path))) - -;;; (home-vicinity) should return the vicinity of the user's HOME -;;; directory, the directory which typically contains files which -;;; customize a computer environment for a user. - -(define home-vicinity - (let ((home-path (getenv "HOME"))) - (lambda () home-path))) - -;;; *FEATURES* should be set to a list of symbols describing features -;;; of this implementation. See Template.scm for the list of feature -;;; names. - -(define *features* - '( - source ;can load scheme source files - ;(slib:load-source "filename") - rev4-report ;conforms to - rev3-report ;conforms to - ieee-p1178 ;conforms to - rev4-optional-procedures - rev3-procedures - multiarg/and- - multiarg-apply - rationalize - object-hash - delay - promise - with-file - transcript - ieee-floating-point - eval - pretty-print - object->string - string-case - string-port - system - getenv - defmacro - ;;full-continuation ;not without the -call/cc switch - )) - -(define pretty-print pp) - -(define (object->string x) (obj->string x)) - -;;; Define these if your implementation's syntax can support it and if -;;; they are not already defined. - -(define (1+ n) (+ n 1)) -(define (-1+ n) (+ n -1)) -(define 1- -1+) - -;;; (OUTPUT-PORT-WIDTH ) -(define (output-port-width . arg) 79) - -;;; (OUTPUT-PORT-HEIGHT ) -(define (output-port-height . arg) 24) - -;;; (TMPNAM) makes a temporary file name. -(define tmpnam - (let ((cntr 100)) - (lambda () - (set! cntr (+ 1 cntr)) - (let ((tmp (string-append "slib_" (number->string cntr)))) - (if (file-exists? tmp) (tmpnam) tmp))))) - -;;; FORCE-OUTPUT flushes any pending output on optional arg output port -;;; use this definition if your system doesn't have such a procedure. -(define (force-output . args) - (flush-output-port (if (pair? args) (car args) (current-output-port)))) - -;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string -;;; port versions of CALL-WITH-*PUT-FILE. -(define (call-with-output-string f) - (let ((outsp (open-output-string))) - (f outsp) - (close-output-port outsp))) - -(define (call-with-input-string s f) - (let* ((insp (open-input-string s)) - (res (f insp))) - (close-input-port insp) - res)) - -;;; "rationalize" adjunct procedures. -(define (find-ratio x e) - (let ((rat (rationalize x e))) - (list (numerator rat) (denominator rat)))) -(define (find-ratio-between x y) - (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) - -;;; CHAR-CODE-LIMIT is one greater than the largest integer which can -;;; be returned by CHAR->INTEGER. -(define char-code-limit 256) - -;; MOST-POSITIVE-FIXNUM is used in modular.scm -(define most-positive-fixnum 536870911) - -;;; Return argument -(define (identity x) x) - -;; define an error procedure for the library - -;;; If your implementation provides eval, SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. -(define slib:eval eval) - -(define-macro (defmacro name . forms) - `(define-macro (,name . ,(car forms)) ,@(cdr forms))) - -(define (defmacro? m) (get-eval-expander m)) -(define (macroexpand-1 body) (expand-once body)) -(define (macroexpand body) (expand body)) - -(define (gentemp) (gensym)) - -(define (slib:eval-load evl) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (call-with-input-file - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* ) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - -(define slib:warn - (lambda args - (let ((cep (current-error-port))) - (if (provided? 'trace) (print-call-stack cep)) - (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) - -(define (slib:error . args) - (if (provided? 'trace) (print-call-stack (current-error-port))) - (error 'slib:error "" args)) - -;; define these as appropriate for your system. -(define slib:tab (integer->char 9)) -(define slib:form-feed (integer->char 12)) - -;;; records -(defmacro define-record forms - (let* ((name (car forms)) - (maker-name (symbol-append 'make- name))) - `(begin - (define-struct ,name ,@(cadr forms)) - (define ,maker-name ,name)) - )) - - -(define (promise:force p) (force p)) - -;;; (implementation-vicinity) should be defined to be the pathname of -;;; the directory where any auxillary files to your Scheme -;;; implementation reside. - -(define in-vicinity string-append) - -;;; Define SLIB:EXIT to be the implementation procedure to exit or -;;; return if exitting not supported. -(define slib:exit (lambda args (exit 0))) - -;;; Here for backward compatability -(define scheme-file-suffix - (let ((suffix (case (software-type) - ((NOSVE) "_scm") - (else ".scm")))) - (lambda () suffix))) - -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever -;;; suffix all the module files in SLIB have. See feature 'SOURCE. - -(define (slib:load-source f) (loadq (string-append f (scheme-file-suffix)))) - -;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced -;;; by compiling "foo.scm" if this implementation can compile files. -;;; See feature 'COMPILED. - -(define slib:load-compiled loadq) - -;;; At this point SLIB:LOAD must be able to load SLIB files. - -(define slib:load slib:load-source) - -(define defmacro:eval slib:eval) -(define defmacro:load slib:load) - -;;; If your implementation provides R4RS macros: -;(define macro:eval slib:eval) -;(define macro:load load) - -(slib:load (in-vicinity (library-vicinity) "require")) -; eof diff --git a/module/slib/break.scm b/module/slib/break.scm deleted file mode 100644 index ae92d407d..000000000 --- a/module/slib/break.scm +++ /dev/null @@ -1,149 +0,0 @@ -;;;; "break.scm" Breakpoints for debugging in Scheme. -;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer. -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'qp) - -;;;; BREAKPOINTS - -;;; Typing (init-debug) at top level sets up a continuation for -;;; breakpoint. When (breakpoint arg1 ...) is then called it returns -;;; from the top level continuation and pushes the continuation from -;;; which it was called on breakpoint:continuation-stack. If -;;; (continue) is later called, it pops the topmost continuation off -;;; of breakpoint:continuation-stack and returns #f to it. - -(define breakpoint:continuation-stack '()) - -(define debug:breakpoint - (let ((call-with-current-continuation call-with-current-continuation) - (apply apply) (qpn qpn) - (cons cons) (length length)) - (lambda args - (if (provided? 'trace) (print-call-stack (current-error-port))) - (apply qpn "BREAKPOINT:" args) - (let ((ans - (call-with-current-continuation - (lambda (x) - (set! breakpoint:continuation-stack - (cons x breakpoint:continuation-stack)) - (debug:top-continuation - (length breakpoint:continuation-stack)))))) - (cond ((not (eq? ans breakpoint:continuation-stack)) ans)))))) - -(define debug:continue - (let ((null? null?) (car car) (cdr cdr)) - (lambda args - (cond ((null? breakpoint:continuation-stack) - (display "; no break to continue from") - (newline)) - (else - (let ((cont (car breakpoint:continuation-stack))) - (set! breakpoint:continuation-stack - (cdr breakpoint:continuation-stack)) - (if (null? args) (cont #f) - (apply cont args)))))))) - -(define debug:top-continuation - (if (provided? 'abort) - (lambda (val) (display val) (newline) (abort)) - (begin (display "; type (init-debug)") #f))) - -(define (init-debug) - (call-with-current-continuation - (lambda (x) (set! debug:top-continuation x)))) - -(define breakpoint debug:breakpoint) -(define bkpt debug:breakpoint) -(define continue debug:continue) - -(define breakf - (let ((null? null?) ;These bindings are so that - (not not) ;breakf will not break on parts - (car car) (cdr cdr) ;of itself. - (eq? eq?) (+ +) (zero? zero?) (modulo modulo) - (apply apply) (display display) (breakpoint debug:breakpoint)) - (lambda (function . optname) - ;; (set! trace:indent 0) - (let ((name (if (null? optname) function (car optname)))) - (lambda args - (cond ((and (not (null? args)) - (eq? (car args) 'debug:unbreak-object) - (null? (cdr args))) - function) - (else - (breakpoint name args) - (apply function args)))))))) - -;;; the reason I use a symbol for debug:unbreak-object is so -;;; that functions can still be unbreaked if this file is read in twice. - -(define (unbreakf function) - ;; (set! trace:indent 0) - (function 'debug:unbreak-object)) - -;;;;The break: functions wrap around the debug: functions to provide -;;; niceties like keeping track of breakd functions and dealing with -;;; redefinition. - -(require 'alist) -(define break:adder (alist-associator eq?)) -(define break:deler (alist-remover eq?)) - -(define *breakd-procedures* '()) -(define (break:breakf fun sym) - (cond ((not (procedure? fun)) - (display "WARNING: not a procedure " (current-error-port)) - (display sym (current-error-port)) - (newline (current-error-port)) - (set! *breakd-procedures* (break:deler *breakd-procedures* sym)) - fun) - (else - (let ((p (assq sym *breakd-procedures*))) - (cond ((and p (eq? (cdr p) fun)) - fun) - (else - (let ((tfun (breakf fun sym))) - (set! *breakd-procedures* - (break:adder *breakd-procedures* sym tfun)) - tfun))))))) - -(define (break:unbreakf fun sym) - (let ((p (assq sym *breakd-procedures*))) - (set! *breakd-procedures* (break:deler *breakd-procedures* sym)) - (cond ((not (procedure? fun)) fun) - ((not p) fun) - ((eq? (cdr p) fun) - (unbreakf fun)) - (else fun)))) - -;;;; Finally, the macros break and unbreak - -(defmacro break xs - (if (null? xs) - `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) - (map car *breakd-procedures*)) - (map car *breakd-procedures*)) - `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) xs)))) -(defmacro unbreak xs - (if (null? xs) - (slib:eval - `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x))) - (map car *breakd-procedures*)) - '',(map car *breakd-procedures*))) - `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x))) xs)))) diff --git a/module/slib/byte.scm b/module/slib/byte.scm deleted file mode 100644 index b34816da5..000000000 --- a/module/slib/byte.scm +++ /dev/null @@ -1,15 +0,0 @@ -;;; "byte.scm" small integers, not necessarily chars. - -(define (byte-ref str ind) (char->integer (string-ref str ind))) -(define (byte-set! str ind val) (string-set! str ind (integer->char val))) -(define (make-bytes len . opt) - (if (null? opt) (make-string len) - (make-string len (integer->char (car opt))))) -(define bytes-length string-length) -(define (write-byte byt . opt) (apply write-char (integer->char byt) opt)) -(define (read-byte . opt) - (let ((c (apply read-char opt))) - (if (eof-object? c) c (char->integer c)))) -(define (bytes . args) (list->bytes args)) -(define (bytes->list bts) (map char->integer (string->list bts))) -(define (list->bytes lst) (list->string (map integer->char lst))) diff --git a/module/slib/chap.scm b/module/slib/chap.scm deleted file mode 100644 index 6a20aebf3..000000000 --- a/module/slib/chap.scm +++ /dev/null @@ -1,150 +0,0 @@ -;;;; "chap.scm" Chapter ordering -*-scheme-*- -;;; Copyright 1992, 1993, 1994 Aubrey Jaffer. -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;; The CHAP: functions deal with strings which are ordered like -;;; chapters in a book. For instance, a_9 < a_10 and 4c < 4aa. Each -;;; section of the string consists of consecutive numeric or -;;; consecutive aphabetic characters. - -(define (chap:string= i l1) (not (>= i l2))) - ((>= i l2) #f) - (else - (let ((c1 (string-ref s1 i)) - (c2 (string-ref s2 i))) - (cond ((char=? c1 c2) - (if (ctypep c1) - (match-so-far (+ 1 i) ctypep) - (delimited i))) - ((ctypep c1) - (if (ctypep c2) - (length-race (+ 1 i) ctypep (char= i l1) (if (>= i l2) def #t)) - ((>= i l2) #f) - (else - (let ((c1 (string-ref s1 i)) - (c2 (string-ref s2 i))) - (cond ((ctypep c1) - (if (ctypep c2) - (length-race (+ 1 i) ctypep def) - #f)) - ((ctypep c2) #t) - (else def)))))) - (define (ctype c1) - (cond - ((char-numeric? c1) char-numeric?) - ((char-lower-case? c1) char-lower-case?) - ((char-upper-case? c1) char-upper-case?) - (else #f))) - (define (delimited i) - (cond ((>= i l1) (not (>= i l2))) - ((>= i l2) #f) - (else - (let* ((c1 (string-ref s1 i)) - (c2 (string-ref s2 i)) - (ctype1 (ctype c1))) - (cond ((char=? c1 c2) - (if ctype1 (match-so-far (+ i 1) ctype1) - (delimited (+ i 1)))) - ((and ctype1 (eq? ctype1 (ctype c2))) - (length-race (+ 1 i) ctype1 (charinteger #\2) (char->integer #\1))) - -(define (chap:inc-string s p) - (let ((c (string-ref s p))) - (cond ((char=? c #\z) - (string-set! s p #\a) - (cond ((zero? p) (string-append "a" s)) - ((char-lower-case? (string-ref s (+ -1 p))) - (chap:inc-string s (+ -1 p))) - (else - (string-append - (substring s 0 p) - "a" - (substring s p (string-length s)))))) - ((char=? c #\Z) - (string-set! s p #\A) - (cond ((zero? p) (string-append "A" s)) - ((char-upper-case? (string-ref s (+ -1 p))) - (chap:inc-string s (+ -1 p))) - (else - (string-append - (substring s 0 p) - "A" - (substring s p (string-length s)))))) - ((char=? c #\9) - (string-set! s p #\0) - (cond ((zero? p) (string-append "1" s)) - ((char-numeric? (string-ref s (+ -1 p))) - (chap:inc-string s (+ -1 p))) - (else - (string-append - (substring s 0 p) - "1" - (substring s p (string-length s)))))) - ((or (char-alphabetic? c) (char-numeric? c)) - (string-set! s p (integer->char - (+ chap:char-incr - (char->integer (string-ref s p))))) - s) - (else (slib:error "inc-string error" s p))))) - -(define (chap:next-string s) - (do ((i (+ -1 (string-length s)) (+ -1 i))) - ((or (negative? i) - (char-numeric? (string-ref s i)) - (char-alphabetic? (string-ref s i))) - (if (negative? i) (string-append s "0") - (chap:inc-string (string-copy s) i))))) - -;;; testing utilities -;(define (ns s1) (chap:next-string s1)) - -;(define (ts s1 s2) -; (let ((s< (chap:string (chap:string -; (display s1) -; (display " > ") -; (display s2) -; (newline))))) - -(define (chap:string>? s1 s2) (chap:string=? s1 s2) (not (chap:stringstring x) - (sprintf #f "%g" x)) - -(define (charplot:scale-it z scale) - (if (and (exact? z) (integer? z)) - (quotient (* z (car scale)) (cadr scale)) - (inexact->exact (round (/ (* z (car scale)) (cadr scale)))))) - -(define (charplot:find-scale isize delta) - (define (fs2) - (cond ((< (* delta 8) isize) 8) - ((< (* delta 6) isize) 6) - ((< (* delta 5) isize) 5) - ((< (* delta 4) isize) 4) - ((< (* delta 3) isize) 3) - ((< (* delta 2) isize) 2) - (else 1))) - (cond ((zero? delta) (set! delta 1)) - ((inexact? delta) (set! isize (exact->inexact isize)))) - (do ((d 1 (* d 10))) - ((<= delta isize) - (do ((n 1 (* n 10))) - ((>= (* delta 10) isize) - (list (* n (fs2)) d)) - (set! delta (* delta 10)))) - (set! isize (* isize 10)))) - -(define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale) - (define xaxis (- (charplot:scale-it ymin yscale))) - (define yaxis (- (charplot:scale-it xmin xscale))) - (charplot:center-print! ylabel 11) - (charplot:printn! (+ charplot:width 1) charplot:xborder) - (newline) - (set! data (sort! data (lambda (x y) (if (= (cdr x) (cdr y)) - (< (car x) (car y)) - (> (cdr x) (cdr y)))))) - (do ((ht (- charplot:height 1) (- ht 1))) - ((negative? ht)) - (let ((a (make-string (+ charplot:width 1) - (if (= ht xaxis) charplot:xaxchar #\ ))) - (ystep (if (= 1 (gcd (car yscale) 3)) 2 3))) - (string-set! a charplot:width charplot:yborder) - (if (< -1 yaxis charplot:width) (string-set! a yaxis charplot:yaxchar)) - (do () - ((or (null? data) (not (>= (cdar data) ht)))) - (string-set! a (caar data) charplot:curve1) - (set! data (cdr data))) - (if (zero? (modulo (- ht xaxis) ystep)) - (let* ((v (charplot:number->string (/ (* (- ht xaxis) (cadr yscale)) - (car yscale)))) - (l (string-length v))) - (if (> l 10) - (display (substring v 0 10)) - (begin - (charplot:printn! (- 10 l) #\ ) - (display v))) - (display charplot:yborder) - (display charplot:xaxchar)) - (begin - (charplot:printn! 10 #\ ) - (display charplot:yborder) - (display #\ ))) - (display a) (newline))) - (let* ((xstep (if (= 1 (gcd (car xscale) 3)) 10 12)) - (xstep/2 (quotient (- xstep 2) 2)) - (fudge (modulo yaxis xstep))) - (charplot:printn! 10 #\ ) (display charplot:yborder) - (charplot:printn! (+ 1 fudge) charplot:xborder) - (display charplot:yaxchar) - (do ((i fudge (+ i xstep))) - ((> (+ i xstep) charplot:width) - (charplot:printn! (modulo (- charplot:width (+ i 1)) xstep) - charplot:xborder)) - (charplot:printn! xstep/2 charplot:xborder) - (display charplot:xtick) - (charplot:printn! xstep/2 charplot:xborder) - (display charplot:yaxchar)) - (display charplot:yborder) (newline) - (charplot:center-print! xlabel (+ 12 fudge (- xstep/2))) - (do ((i fudge (+ i xstep))) - ((>= i charplot:width)) - (charplot:center-print! (charplot:number->string - (/ (* (- i yaxis) (cadr xscale)) - (car xscale))) - xstep)) - (newline))) - -(define (charplot:plot! data xlabel ylabel) - (cond ((array? data) - (case (array-rank data) - ((1) (set! data (map cons - (let ((ra (apply make-array #f - (array-shape data)))) - (array-index-map! ra identity) - (array->list ra)) - (array->list data)))) - ((2) (set! data (map (lambda (lst) (cons (car lst) (cadr lst))) - (array->list data))))))) - (let* ((xmax (apply max (map car data))) - (xmin (apply min (map car data))) - (xscale (charplot:find-scale charplot:width (- xmax xmin))) - (ymax (apply max (map cdr data))) - (ymin (apply min (map cdr data))) - (yscale (charplot:find-scale charplot:height (- ymax ymin))) - (ixmin (charplot:scale-it xmin xscale)) - (iymin (charplot:scale-it ymin yscale))) - (charplot:iplot! (map (lambda (p) - (cons (- (charplot:scale-it (car p) xscale) ixmin) - (- (charplot:scale-it (cdr p) yscale) iymin))) - data) - xlabel ylabel xmin xscale ymin yscale))) - -(define (plot-function! func vlo vhi . npts) - (set! npts (if (null? npts) 100 (car npts))) - (let ((dats (make-array 0.0 npts 2))) - (array-index-map! (make-shared-array dats (lambda (idx) (list idx 0)) npts) - (lambda (idx) (+ vlo (* (- vhi vlo) (/ idx npts))))) - (array-map! (make-shared-array dats (lambda (idx) (list idx 1)) npts) - func - (make-shared-array dats (lambda (idx) (list idx 0)) npts)) - (charplot:plot! dats "" ""))) - -(define plot! charplot:plot!) diff --git a/module/slib/chez.init b/module/slib/chez.init deleted file mode 100644 index d5cdbb539..000000000 --- a/module/slib/chez.init +++ /dev/null @@ -1,396 +0,0 @@ -;;;"chez.init" Initialization file for SLIB for Chez Scheme 6.0a -*-scheme-*- -;;; Authors: dorai@cs.rice.edu (Dorai Sitaram) and Aubrey Jaffer. -;;; -;;; This code is in the public domain. - -;;; Adapted to version 5.0c by stone@math.grin.edu (John David Stone) 1997 -;;; Adapted to version 6.0a by Gary T. Leavens , 1999 - -;;; (software-type) should be set to the generic operating system type. -;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - -(define (software-type) 'UNIX) - -;;; (scheme-implementation-type) should return the name of the scheme -;;; implementation loading this file. - -(define (scheme-implementation-type) 'chez) - -;;; (scheme-implementation-home-page) should return a (string) URI -;;; (Uniform Resource Identifier) for this scheme implementation's home -;;; page; or false if there isn't one. - -(define (scheme-implementation-home-page) - "http://www.cs.indiana.edu/chezscheme/") - -;;; (scheme-implementation-version) should return a string describing -;;; the version the scheme implementation loading this file. - -(define (scheme-implementation-version) "6.0a") - -;;; (implementation-vicinity) should be defined to be the pathname of -;;; the directory where any auxillary files to your Scheme -;;; implementation reside. - -(define implementation-vicinity - (lambda () "/usr/unsup/scheme/chez/")) - -;;; (library-vicinity) should be defined to be the pathname of the -;;; directory where files of Scheme library functions reside. - -(define library-vicinity - (let ((library-path - (or - ;; Use this getenv if your implementation supports it. - (getenv "SCHEME_LIBRARY_PATH") - ;; Use this path if your scheme does not support GETENV - ;; or if SCHEME_LIBRARY_PATH is not set. - (case (software-type) - ((UNIX) "/usr/local/lib/slib/") - ((VMS) "lib$scheme:") - ((MS-DOS) "C:\\SLIB\\") - (else ""))))) - (lambda () library-path))) - -;;; (home-vicinity) should return the vicinity of the user's HOME -;;; directory, the directory which typically contains files which -;;; customize a computer environment for a user. - -(define home-vicinity - (let ((home-path (getenv "HOME"))) - (lambda () home-path))) - -;;; *FEATURES* should be set to a list of symbols describing features -;;; of this implementation. Suggestions for features are: - -(define *features* - '( - source ; Chez Scheme can load Scheme source files, with the - ; command (slib:load-source "filename") -- see below. - - compiled ; Chez Scheme can also load compiled Scheme files, with the - ; command (slib:load-compiled "filename") -- see below. - rev4-report ;conforms to - rev3-report ;conforms to - ieee-p1178 ;conforms to -; sicp ;runs code from Structure and - ;Interpretation of Computer - ;Programs by Abelson and Sussman. - rev4-optional-procedures ;LIST-TAIL, STRING->LIST, - ;LIST->STRING, STRING-COPY, - ;STRING-FILL!, LIST->VECTOR, - ;VECTOR->LIST, and VECTOR-FILL! -; rev2-procedures ;SUBSTRING-MOVE-LEFT!, - ;SUBSTRING-MOVE-RIGHT!, - ;SUBSTRING-FILL!, - ;STRING-NULL?, APPEND!, 1+, - ;-1+, ?, >=? - multiarg/and- ;/ and - can take more than 2 args. - multiarg-apply ;APPLY can take more than 2 args. - rationalize - delay ;has DELAY and FORCE - with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE - string-port ;has CALL-WITH-INPUT-STRING and - ;CALL-WITH-OUTPUT-STRING - transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF - char-ready? - macro ;has R4RS high level macros -; defmacro ;has Common Lisp DEFMACRO - eval ;R5RS two-argument eval - record ;has user defined data structures - values ;proposed multiple values - dynamic-wind ;proposed dynamic-wind -; ieee-floating-point ;conforms to - full-continuation ;can return multiple times -; object-hash ;has OBJECT-HASH - - sort -; queue ;queues - pretty-print -; object->string - format - trace ;has macros: TRACE and UNTRACE -; compiler ;has (COMPILER) -; ed ;(ED) is editor - system ;posix (system ) - 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 - fluid-let - random - rev3-procedures - )) - -;;; (OUTPUT-PORT-WIDTH ) returns the number of graphic characters -;;; that can reliably be displayed on one line of the standard output port. - -(define output-port-width - (lambda arg - (let ((env-width-string (getenv "COLUMNS"))) - (if (and env-width-string - (let loop ((remaining (string-length env-width-string))) - (or (zero? remaining) - (let ((next (- remaining 1))) - (and (char-numeric? (string-ref env-width-string - next)) - (loop next)))))) - (- (string->number env-width-string) 1) - 79)))) - -;;; (OUTPUT-PORT-HEIGHT ) returns the number of lines of text that -;;; can reliably be displayed simultaneously in the standard output port. - -(define output-port-height - (lambda arg - (let ((env-height-string (getenv "LINES"))) - (if (and env-height-string - (let loop ((remaining (string-length env-height-string))) - (or (zero? remaining) - (let ((next (- remaining 1))) - (and (char-numeric? (string-ref env-height-string - next)) - (loop next)))))) - (string->number env-height-string) - 24)))) - -;;; (CURRENT-ERROR-PORT) -(define current-error-port - (let ((port (console-output-port))) ; changed from current-output-port - (lambda () port))) - -;;; (TMPNAM) makes a temporary file name. -(define tmpnam - (let ((cntr 100)) - (lambda () - (set! cntr (+ 1 cntr)) - (let ((tmp (string-append "slib_" (number->string cntr)))) - (if (file-exists? tmp) (tmpnam) tmp))))) - -;;; (FILE-EXISTS? ) is built-in to Chez Scheme - -;;; (DELETE-FILE ) is built-in to Chez Scheme - -;; The FORCE-OUTPUT requires buffered output that has been written to a -;; port to be transferred all the way out to its ultimate destination. -(define force-output flush-output-port) - -;;; "rationalize" adjunct procedures. -(define (find-ratio x e) - (let ((rat (rationalize x e))) - (list (numerator rat) (denominator rat)))) -(define (find-ratio-between x y) - (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) - -;;; CHAR-CODE-LIMIT is one greater than the largest integer which can -;;; be returned by CHAR->INTEGER. -(define char-code-limit 256) - -;;; MOST-POSITIVE-FIXNUM is used in modular.scm -;; Chez's MOST-POSITIVE-FIXNUM is a thunk rather than a number. - -(if (procedure? most-positive-fixnum) - (set! most-positive-fixnum (most-positive-fixnum))) - -;;; Return argument -(define (identity x) x) - -;;; SLIB:EVAL is single argument eval using the top-level (user) environment. -(define slib:eval eval) - -;;; define an error procedure for the library -(define slib:error - (lambda args - (let ((cep (current-error-port))) - (if (provided? 'trace) (print-call-stack cep)) - (display "Error: " cep) - (for-each (lambda (x) (display x cep)) args) - (error #f "")))) - -;;; define these as appropriate for your system. -(define slib:tab #\tab) -(define slib:form-feed #\page) - -;;; Support for older versions of Scheme. Not enough code for its own file. -;;; last-pair is built-in to Chez Scheme -(define t #t) -(define nil #f) - -;;; Define these if your implementation's syntax can support it and if -;;; they are not already defined. -;;; 1+, -1+, and 1- are built-in to Chez Scheme -;(define (1+ n) (+ n 1)) -;(define (-1+ n) (+ n -1)) -;(define 1- -1+) - -;;; (IN-VICINITY ) is simply STRING-APPEND, conventionally used -;;; to attach a directory pathname to the name of a file that is expected to -;;; be in that directory. -(define in-vicinity string-append) - -;;; Define SLIB:EXIT to be the implementation procedure to exit or -;;; return if exitting not supported. -(define slib:chez:quit - (let ((arg (call-with-current-continuation identity))) - (cond ((procedure? arg) arg) - (arg (exit)) - (else (exit 1))))) - -(define slib:exit - (lambda args - (cond ((null? args) (slib:chez:quit #t)) - ((eqv? #t (car args)) (slib:chez:quit #t)) - ((eqv? #f (car args)) (slib:chez:quit #f)) - ((zero? (car args)) (slib:chez:quit #t)) - (else (slib:chez:quit #f))))) - -;;; For backward compatability, the SCHEME-FILE-SUFFIX procedure is defined -;;; to return the string ".scm". Note, however, that ".ss" is a common Chez -;;; file suffix. -(define scheme-file-suffix - (let ((suffix (case (software-type) - ((NOSVE) "_scm") - (else ".scm")))) - (lambda () suffix))) - -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever -;;; suffix all the module files in SLIB have. See feature 'SOURCE. - -(define (slib:load-source f) (load (string-append f ".scm"))) - -;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced -;;; by compiling "foo.scm" if this implementation can compile files. -;;; See feature 'COMPILED. - -(define slib:load-compiled load) - -;;; At this point SLIB:LOAD must be able to load SLIB files. - -(define slib:load slib:load-source) - -;;; The following make procedures in Chez Scheme compatible with -;;; the assumptions of SLIB. - -;;; Chez's sorting routines take parameters in the order opposite to SLIB's. -;;; The following definitions override the predefined procedures with the -;;; parameters-reversed versions. See the SORT feature. - -(define chez:sort sort) -(define chez:sort! sort!) -(define chez:merge merge) -(define chez:merge! merge!) - -(define sort - (lambda (s p) - (chez:sort p s))) -(define sort! - (lambda (s p) - (chez:sort! p s))) -(define merge - (lambda (s1 s2 p) - (chez:merge p s1 s2))) -(define merge! - (lambda (s1 s2 p) - (chez:merge! p s1 s2))) - -;;; Chez's (FORMAT F . A) corresponds to SLIB's (FORMAT #F F . A) -;;; See the FORMAT feature. - -(define chez:format format) - -(define format - (lambda (where how . args) - (let ((str (apply chez:format how args))) - (cond ((not where) str) - ((eq? where #t) (display str)) - (else (display str where)))))) - -;; The following definitions implement a few widely useful procedures that -;; Chez Scheme does not provide or provides under a different name. - -;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string -;;; port versions of CALL-WITH-INPUT-FILE and CALL-WITH-OUTPUT-FILE. -;;; See the STRING-PORT feature. - -(define call-with-output-string - (lambda (f) - (let ((outsp (open-output-string))) - (f outsp) - (let ((s (get-output-string outsp))) - (close-output-port outsp) - s)))) - -(define call-with-input-string - (lambda (s f) - (let* ((insp (open-input-string s)) - (res (f insp))) - (close-input-port insp) - res))) - -;;; If your implementation provides R4RS macros: -(define macro:eval slib:eval) -;;; macro:load also needs the default suffix. -(define macro:load slib:load-source) - -(define *defmacros* - (list (cons 'defmacro - (lambda (name parms . body) - `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) - *defmacros*)))))) -(define (defmacro? m) (and (assq m *defmacros*) #t)) - -(define (macroexpand-1 e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) (set! a (assq a *defmacros*)) - (if a (apply (cdr a) (cdr e)) e)) - (else e))) - e)) - -(define (macroexpand e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) - (set! a (assq a *defmacros*)) - (if a (macroexpand (apply (cdr a) (cdr e))) e)) - (else e))) - e)) - -;;; According to Kent Dybvig, you can improve the Chez Scheme init -;;; file by defining gentemp to be gensym in Chez Scheme. -(define gentemp gensym) - -(define base:eval slib:eval) -(define (defmacro:eval x) (base:eval (defmacro:expand* x))) -(define (defmacro:expand* x) - (require 'defmacroexpand) (apply defmacro:expand* x '())) - -(define (slib:eval-load evl) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (call-with-input-file - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* ) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - -(define (defmacro:load ) - (slib:eval-load defmacro:eval)) - -(define slib:warn - (lambda args - (let ((cep (current-error-port))) - (if (provided? 'trace) (print-call-stack cep)) - (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) - -;;; Load the REQUIRE package. - -(slib:load (in-vicinity (library-vicinity) "require")) - -;; end of chez.init diff --git a/module/slib/cltime.scm b/module/slib/cltime.scm deleted file mode 100644 index 441e7f985..000000000 --- a/module/slib/cltime.scm +++ /dev/null @@ -1,67 +0,0 @@ -;;;; "cltime.scm" Common-Lisp time conversion routines. -;;; Copyright (C) 1994, 1997 Aubrey Jaffer. -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'values) -(require 'time-zone) -(require 'posix-time) - -(define time:1900 (time:invert time:gmtime '#(0 0 0 1 0 0 #f #f 0 0 "GMT"))) - -(define (get-decoded-time) - (decode-universal-time (get-universal-time))) - -(define (get-universal-time) - (difftime (current-time) time:1900)) - -(define (decode-universal-time utime . tzarg) - (let ((tv (apply time:split - (offset-time time:1900 utime) - (if (null? tzarg) - (tz:params utime (tzset)) - (list 0 (* 3600 (car tzarg)) "???"))))) - (values - (vector-ref tv 0) ;second [0..59] - (vector-ref tv 1) ;minute [0..59] - (vector-ref tv 2) ;hour [0..23] - (vector-ref tv 3) ;date [1..31] - (+ 1 (vector-ref tv 4)) ;month [1..12] - (+ 1900 (vector-ref tv 5)) ;year [0....] - (modulo (+ -1 (vector-ref tv 6)) 7) ;day-of-week [0..6] (0 is Monday) - (eqv? 1 (vector-ref tv 8)) ;daylight-saving-time? - (if (provided? 'inexact) - (inexact->exact (/ (vector-ref tv 9) 3600)) - (/ (vector-ref tv 9) 3600)) ;time-zone [-24..24] - ))) - -(define (encode-universal-time second minute hour date month year . tzarg) - (let* ((tz (if (null? tzarg) - (tzset) - (time-zone (string-append - "???" (number->string (car tzarg)))))) - (tv (vector second - minute - hour - date - (+ -1 month) - (+ -1900 year) - #f ;ignored - #f ;ignored - ))) - (difftime (time:invert localtime tv) time:1900))) - diff --git a/module/slib/coerce.scm b/module/slib/coerce.scm deleted file mode 100644 index b2e58a770..000000000 --- a/module/slib/coerce.scm +++ /dev/null @@ -1,107 +0,0 @@ -;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF. -; Copyright (C) 1995, 2001 Aubrey Jaffer. -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;@body -;;Returns a symbol name for the type of @1. -(define (type-of obj) - (cond - ;;((null? obj) 'null) - ((boolean? obj) 'boolean) - ((char? obj) 'char) - ((number? obj) 'number) - ((string? obj) 'string) - ((symbol? obj) 'symbol) - ((input-port? obj) 'port) - ((output-port? obj) 'port) - ((procedure? obj) 'procedure) - ((eof-object? obj) 'eof-object) - ((list? obj) 'list) - ((pair? obj) 'pair) - ((and (provided? 'array) (array? obj)) 'array) - ((and (provided? 'record) (record? obj)) 'record) - ((vector? obj) 'vector) - (else '?))) - -;;@body -;;Converts and returns @1 of type @code{char}, @code{number}, -;;@code{string}, @code{symbol}, @code{list}, or @code{vector} to -;;@2 (which must be one of these symbols). -(define (coerce obj result-type) - (define (err) (slib:error 'coerce 'not obj '-> result-type)) - (define obj-type (type-of obj)) - (cond - ((eq? obj-type result-type) obj) - (else - (case obj-type - ((char) (case result-type - ((number integer) (char->integer obj)) - ((string) (string obj)) - ((symbol) (string->symbol (string obj))) - ((list) (list obj)) - ((vector) (vector obj)) - (else (err)))) - ((number) (case result-type - ((char) (integer->char obj)) - ((atom) obj) - ((integer) obj) - ((string) (number->string obj)) - ((symbol) (string->symbol (number->string obj))) - ((list) (string->list (number->string obj))) - ((vector) (list->vector (string->list (number->string obj)))) - (else (err)))) - ((string) (case result-type - ((char) (if (= 1 (string-length obj)) (string-ref obj 0) - (err))) - ((atom) (or (string->number obj) (string->symbol obj))) - ((number integer) (or (string->number obj) (err))) - ((symbol) (string->symbol obj)) - ((list) (string->list obj)) - ((vector) (list->vector (string->list obj))) - (else (err)))) - ((symbol) (case result-type - ((char) (coerce (symbol->string obj) 'char)) - ((number integer) (coerce (symbol->string obj) 'number)) - ((string) (symbol->string obj)) - ((atom) obj) - ((list) (string->list (symbol->string obj))) - ((vector) (list->vector (string->list (symbol->string obj)))) - (else (err)))) - ((list) (case result-type - ((char) (if (and (= 1 (length obj)) - (char? (car obj))) - (car obj) - (err))) - ((number integer) - (or (string->number (list->string obj)) (err))) - ((string) (list->string obj)) - ((symbol) (string->symbol (list->string obj))) - ((vector) (list->vector obj)) - (else (err)))) - ((vector) (case result-type - ((char) (if (and (= 1 (vector-length obj)) - (char? (vector-ref obj 0))) - (vector-ref obj 0) - (err))) - ((number integer) - (or (string->number (coerce obj string)) (err))) - ((string) (list->string (vector->list obj))) - ((symbol) (string->symbol (coerce obj string))) - ((list) (list->vector obj)) - (else (err)))) - (else (err)))))) diff --git a/module/slib/coerce.txi b/module/slib/coerce.txi deleted file mode 100644 index 4b7f6b0ad..000000000 --- a/module/slib/coerce.txi +++ /dev/null @@ -1,12 +0,0 @@ - -@defun type-of obj - -Returns a symbol name for the type of @var{obj}. -@end defun - -@defun coerce obj result-type - -Converts and returns @var{obj} of type @code{char}, @code{number}, -@code{string}, @code{symbol}, @code{list}, or @code{vector} to -@var{result-type} (which must be one of these symbols). -@end defun diff --git a/module/slib/collect.scm b/module/slib/collect.scm deleted file mode 100644 index 35a333d4e..000000000 --- a/module/slib/collect.scm +++ /dev/null @@ -1,236 +0,0 @@ -;"collect.scm" Sample collection operations -; COPYRIGHT (c) Kenneth Dickey 1992 -; -; This software may be used for any purpose whatever -; without warrantee of any kind. -; AUTHOR Ken Dickey -; DATE 1992 September 1 -; LAST UPDATED 1992 September 2 -; NOTES Expository (optimizations & checks elided). -; Requires YASOS (Yet Another Scheme Object System). - -(require 'yasos) - -(define-operation (collect:collection? obj) - ;; default - (cond - ((or (list? obj) (vector? obj) (string? obj)) #t) - (else #f) -) ) - -(define (collect:empty? collection) (zero? (yasos:size collection))) - -(define-operation (collect:gen-elts ) ;; return element generator - ;; default behavior - (cond ;; see utilities, below, for generators - ((vector? ) (collect:vector-gen-elts )) - ((list? ) (collect:list-gen-elts )) - ((string? ) (collect:string-gen-elts )) - (else - (slib:error "Operation not supported: GEN-ELTS " (yasos:print obj #f))) -) ) - -(define-operation (collect:gen-keys collection) - (if (or (vector? collection) (list? collection) (string? collection)) - (let ( (max+1 (yasos:size collection)) (index 0) ) - (lambda () - (cond - ((< index max+1) - (set! index (collect:add1 index)) - (collect:sub1 index)) - (else (slib:error "no more keys in generator")) - ) ) ) - (slib:error "Operation not handled: GEN-KEYS " collection) -) ) - -(define (collect:do-elts . ) - (let ( (max+1 (yasos:size (car ))) - (generators (map collect:gen-elts )) - ) - (let loop ( (counter 0) ) - (cond - ((< counter max+1) - (apply (map (lambda (g) (g)) generators)) - (loop (collect:add1 counter)) - ) - (else 'unspecific) ; done - ) ) -) ) - -(define (collect:do-keys . ) - (let ( (max+1 (yasos:size (car ))) - (generators (map collect:gen-keys )) - ) - (let loop ( (counter 0) ) - (cond - ((< counter max+1) - (apply (map (lambda (g) (g)) generators)) - (loop (collect:add1 counter)) - ) - (else 'unspecific) ; done - ) ) -) ) - -(define (collect:map-elts . ) - (let ( (max+1 (yasos:size (car ))) - (generators (map collect:gen-elts )) - (vec (make-vector (yasos:size (car )))) - ) - (let loop ( (index 0) ) - (cond - ((< index max+1) - (vector-set! vec index (apply (map (lambda (g) (g)) generators))) - (loop (collect:add1 index)) - ) - (else vec) ; done - ) ) -) ) - -(define (collect:map-keys . ) - (let ( (max+1 (yasos:size (car ))) - (generators (map collect:gen-keys )) - (vec (make-vector (yasos:size (car )))) - ) - (let loop ( (index 0) ) - (cond - ((< index max+1) - (vector-set! vec index (apply (map (lambda (g) (g)) generators))) - (loop (collect:add1 index)) - ) - (else vec) ; done - ) ) -) ) - -(define-operation (collect:for-each-key ) - ;; default - (collect:do-keys ) ;; talk about lazy! -) - -(define-operation (collect:for-each-elt ) - (collect:do-elts ) -) - -(define (collect:reduce . ) - (let ( (max+1 (yasos:size (car ))) - (generators (map collect:gen-elts )) - ) - (let loop ( (count 0) ) - (cond - ((< count max+1) - (set! - (apply (map (lambda (g) (g)) generators))) - (loop (collect:add1 count)) - ) - (else ) - ) ) -) ) - - - -;; pred true for every elt? -(define (collect:every? . ) - (let ( (max+1 (yasos:size (car ))) - (generators (map collect:gen-elts )) - ) - (let loop ( (count 0) ) - (cond - ((< count max+1) - (if (apply (map (lambda (g) (g)) generators)) - (loop (collect:add1 count)) - #f) - ) - (else #t) - ) ) -) ) - -;; pred true for any elt? -(define (collect:any? . ) - (let ( (max+1 (yasos:size (car ))) - (generators (map collect:gen-elts )) - ) - (let loop ( (count 0) ) - (cond - ((< count max+1) - (if (apply (map (lambda (g) (g)) generators)) - #t - (loop (collect:add1 count)) - )) - (else #f) - ) ) -) ) - - -;; MISC UTILITIES - -(define (collect:add1 obj) (+ obj 1)) -(define (collect:sub1 obj) (- obj 1)) - -;; Nota Bene: list-set! is bogus for element 0 - -(define (collect:list-set! ) - - (define (set-loop last this idx) - (cond - ((zero? idx) - (set-cdr! last (cons (cdr this))) - - ) - (else (set-loop (cdr last) (cdr this) (collect:sub1 idx))) - ) ) - - ;; main - (if (zero? ) - (cons (cdr )) ;; return value - (set-loop (cdr ) (collect:sub1 ))) -) - -(add-setter list-ref collect:list-set!) ; for (setter list-ref) - - -;; generator for list elements -(define (collect:list-gen-elts ) - (lambda () - (if (null? ) - (slib:error "No more list elements in generator") - (let ( (elt (car )) ) - (set! (cdr )) - elt)) -) ) - -;; generator for vector elements -(define (collect:make-vec-gen-elts ) - (lambda (vec) - (let ( (max+1 (yasos:size vec)) - (index 0) - ) - (lambda () - (cond ((< index max+1) - (set! index (collect:add1 index)) - ( vec (collect:sub1 index)) - ) - (else #f) - ) ) - ) ) -) - -(define collect:vector-gen-elts (collect:make-vec-gen-elts vector-ref)) - -(define collect:string-gen-elts (collect:make-vec-gen-elts string-ref)) - -;;; exports: - -(define collection? collect:collection?) -(define empty? collect:empty?) -(define gen-keys collect:gen-keys) -(define gen-elts collect:gen-elts) -(define do-elts collect:do-elts) -(define do-keys collect:do-keys) -(define map-elts collect:map-elts) -(define map-keys collect:map-keys) -(define for-each-key collect:for-each-key) -(define for-each-elt collect:for-each-elt) -(define reduce collect:reduce) ; reduce is also in comlist.scm -(define every? collect:every?) -(define any? collect:any?) - -;; --- E O F "collect.oo" --- ;; diff --git a/module/slib/comlist.scm b/module/slib/comlist.scm deleted file mode 100644 index bea99a70a..000000000 --- a/module/slib/comlist.scm +++ /dev/null @@ -1,328 +0,0 @@ -;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme -; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer. -; Copyright (C) 2000 Colin Walters -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;; Some of these functions may be already defined in your Scheme. -;;; Comment out those definitions for functions which are already defined. - -;;;; LIST FUNCTIONS FROM COMMON LISP - -;;; Some tail-recursive optimizations made by -;;; Colin Walters - -;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) -(define (comlist:make-list k . init) - (set! init (if (pair? init) (car init))) - (do ((k k (+ -1 k)) - (result '() (cons init result))) - ((<= k 0) result))) - -(define (comlist:copy-list lst) (append lst '())) - -(define (comlist:adjoin e l) (if (memv e l) l (cons e l))) - -(define (comlist:union l1 l2) - (cond ((null? l1) l2) - ((null? l2) l1) - (else (comlist:union (cdr l1) (comlist:adjoin (car l1) l2))))) - -(define (comlist:intersection l1 l2) - ;; optimization - (if (null? l2) - l2 - (let build-intersection ((l1 l1) - (result '())) - (cond ((null? l1) - result) - ((memv (car l1) l2) (build-intersection (cdr l1) (cons (car l1) result))) - (else (build-intersection (cdr l1) result)))))) - -(define (comlist:set-difference l1 l2) - ;; optimization - (if (null? l2) - l1 - (let build-difference ((l1 l1) - (result '())) - (cond ((null? l1) - result) - ((memv (car l1) l2) (build-difference (cdr l1) result)) - (else (build-difference (cdr l1) (cons (car l1) result))))))) - -(define (comlist:position obj lst) - (letrec ((pos (lambda (n lst) - (cond ((null? lst) #f) - ((eqv? obj (car lst)) n) - (else (pos (+ 1 n) (cdr lst))))))) - (pos 0 lst))) - -(define (comlist:reduce-init p init l) - (if (null? l) - init - (comlist:reduce-init p (p init (car l)) (cdr l)))) - -(define (comlist:reduce p l) - (cond ((null? l) l) - ((null? (cdr l)) (car l)) - (else (comlist:reduce-init p (car l) (cdr l))))) - -(define (comlist:some pred l . rest) - (cond ((null? rest) - (let mapf ((l l)) - (and (not (null? l)) - (or (pred (car l)) (mapf (cdr l)))))) - (else (let mapf ((l l) (rest rest)) - (and (not (null? l)) - (or (apply pred (car l) (map car rest)) - (mapf (cdr l) (map cdr rest)))))))) - -(define (comlist:every pred l . rest) - (cond ((null? rest) - (let mapf ((l l)) - (or (null? l) - (and (pred (car l)) (mapf (cdr l)))))) - (else (let mapf ((l l) (rest rest)) - (or (null? l) - (and (apply pred (car l) (map car rest)) - (mapf (cdr l) (map cdr rest)))))))) - -(define (comlist:notany pred . ls) (not (apply comlist:some pred ls))) - -(define (comlist:notevery pred . ls) (not (apply comlist:every pred ls))) - -(define (comlist:list-of?? predicate . bound) - (define (errout) (apply slib:error 'list-of?? predicate bound)) - (case (length bound) - ((0) - (lambda (obj) - (and (list? obj) - (every predicate obj)))) - ((1) - (set! bound (car bound)) - (cond ((negative? bound) - (set! bound (- bound)) - (lambda (obj) - (and (list? obj) - (<= bound (length obj)) - (every predicate obj)))) - (else - (lambda (obj) - (and (list? obj) - (<= (length obj) bound) - (every predicate obj)))))) - ((2) - (let ((low (car bound)) - (high (cadr bound))) - (cond ((or (negative? low) (negative? high)) (errout)) - ((< high low) - (set! high (car bound)) - (set! low (cadr bound)))) - (lambda (obj) - (and (list? obj) - (<= low (length obj) high) - (every predicate obj))))) - (else (errout)))) - -(define (comlist:find-if t l) - (cond ((null? l) #f) - ((t (car l)) (car l)) - (else (comlist:find-if t (cdr l))))) - -(define (comlist:member-if t l) - (cond ((null? l) #f) - ((t (car l)) l) - (else (comlist:member-if t (cdr l))))) - -(define (comlist:remove p l) - (let remove ((l l) - (result '())) - (cond ((null? l) result) - ((eqv? p (car l)) (remove (cdr l) result)) - (else (remove (cdr l) (cons (car l) result)))))) - -(define (comlist:remove-if p l) - (let remove-if ((l l) - (result '())) - (cond ((null? l) result) - ((p (car l)) (remove-if (cdr l) result)) - (else (remove-if (cdr l) (cons (car l) result)))))) - -(define (comlist:remove-if-not p l) - (let remove-if-not ((l l) - (result '())) - (cond ((null? l) result) - ((p (car l)) (remove-if-not (cdr l) (cons (car l) result))) - (else (remove-if-not (cdr l) result))))) - -(define comlist:nconc - (if (provided? 'rev2-procedures) append! - (lambda args - (cond ((null? args) '()) - ((null? (cdr args)) (car args)) - ((null? (car args)) (apply comlist:nconc (cdr args))) - (else - (set-cdr! (last-pair (car args)) - (apply comlist:nconc (cdr args))) - (car args)))))) - -;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) -(define (comlist:nreverse rev-it) -;;; Reverse order of elements of LIST by mutating cdrs. - (cond ((null? rev-it) rev-it) - ((not (list? rev-it)) - (slib:error "nreverse: Not a list in arg1" rev-it)) - (else (do ((reved '() rev-it) - (rev-cdr (cdr rev-it) (cdr rev-cdr)) - (rev-it rev-it rev-cdr)) - ((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it))))) - -(define (comlist:last lst n) - (comlist:nthcdr (- (length lst) n) lst)) - -(define (comlist:butlast lst n) - (letrec ((l (- (length lst) n)) - (bl (lambda (lst n) - (let build-until-zero ((lst lst) - (n n) - (result '())) - (cond ((null? lst) (reverse result)) - ((positive? n) - (build-until-zero (cdr lst) (- n 1) (cons (car lst) result))) - (else (reverse result))))))) - (bl lst (if (negative? n) - (slib:error "negative argument to butlast" n) - l)))) - -(define (comlist:nthcdr n lst) - (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst)))) - -(define (comlist:butnthcdr n lst) - (letrec ((bl (lambda (lst n) - (let build-until-zero ((lst lst) - (n n) - (result '())) - (cond ((null? lst) (reverse result)) - ((positive? n) - (build-until-zero (cdr lst) (- n 1) (cons (car lst) result))) - (else (reverse result))))))) - (bl lst (if (negative? n) - (slib:error "negative argument to butnthcdr" n) - n)))) - -;;;; CONDITIONALS - -(define (comlist:and? . args) - (cond ((null? args) #t) - ((car args) (apply comlist:and? (cdr args))) - (else #f))) - -(define (comlist:or? . args) - (cond ((null? args) #f) - ((car args) #t) - (else (apply comlist:or? (cdr args))))) - -;;; Checks to see if a list has any duplicate MEMBERs. -(define (comlist:has-duplicates? lst) - (cond ((null? lst) #f) - ((member (car lst) (cdr lst)) #t) - (else (comlist:has-duplicates? (cdr lst))))) - -;;; remove duplicates of MEMBERs of a list -(define (comlist:remove-duplicates lst) - (letrec ((rem-dup - (lambda (lst nlst) - (cond ((null? lst) nlst) - ((member (car lst) nlst) (rem-dup (cdr lst) nlst)) - (else (rem-dup (cdr lst) (cons (car lst) nlst))))))) - (rem-dup lst '()))) - -(define (comlist:list* x . y) - (define (list*1 x) - (if (null? (cdr x)) - (car x) - (cons (car x) (list*1 (cdr x))))) - (if (null? y) - x - (cons x (list*1 y)))) - -(define (comlist:atom? a) - (not (pair? a))) - -(define (comlist:delete obj list) - (let delete ((list list)) - (cond ((null? list) '()) - ((equal? obj (car list)) (delete (cdr list))) - (else - (set-cdr! list (delete (cdr list))) - list)))) - -(define (comlist:delete-if pred list) - (let delete-if ((list list)) - (cond ((null? list) '()) - ((pred (car list)) (delete-if (cdr list))) - (else - (set-cdr! list (delete-if (cdr list))) - list)))) - -(define (comlist:delete-if-not pred list) - (let delete-if ((list list)) - (cond ((null? list) '()) - ((not (pred (car list))) (delete-if (cdr list))) - (else - (set-cdr! list (delete-if (cdr list))) - list)))) - -;;; exports - -(define make-list comlist:make-list) -(define copy-list comlist:copy-list) -(define adjoin comlist:adjoin) -(define union comlist:union) -(define intersection comlist:intersection) -(define set-difference comlist:set-difference) -(define position comlist:position) -(define reduce-init comlist:reduce-init) -(define reduce comlist:reduce) ; reduce is also in collect.scm -(define some comlist:some) -(define every comlist:every) -(define notevery comlist:notevery) -(define notany comlist:notany) -(define find-if comlist:find-if) -(define member-if comlist:member-if) -(define remove comlist:remove) -(define remove-if comlist:remove-if) -(define remove-if-not comlist:remove-if-not) -(define nconc comlist:nconc) -(define nreverse comlist:nreverse) -(define last comlist:last) -(define butlast comlist:butlast) -(define nthcdr comlist:nthcdr) -(define butnthcdr comlist:butnthcdr) -(define and? comlist:and?) -(define or? comlist:or?) -(define has-duplicates? comlist:has-duplicates?) -(define remove-duplicates comlist:remove-duplicates) - -(define delete-if-not comlist:delete-if-not) -(define delete-if comlist:delete-if) -(define delete comlist:delete) -(define comlist:atom comlist:atom?) -(define atom comlist:atom?) -(define atom? comlist:atom?) -(define list* comlist:list*) -(define list-of?? comlist:list-of??) diff --git a/module/slib/comparse.scm b/module/slib/comparse.scm deleted file mode 100644 index 9066e36a7..000000000 --- a/module/slib/comparse.scm +++ /dev/null @@ -1,99 +0,0 @@ -;;; "comparse.scm" Break command line into arguments. -;Copyright (C) 1995, 1997 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;;; This is a simple command-line reader. It could be made fancier -;;; to handle lots of `shell' syntaxes. - -;;; Albert L. Ting points out that a similar process can be used for -;;; reading files of options -- therefore READ-OPTIONS-FILE. - -(require 'string-port) -(define (read-command-from-port port nl-term?) - (define argv '()) - (define obj "") - (define chars '()) - (define readc (lambda () (read-char port))) - (define peekc (lambda () (peek-char port))) - (define s-expression - (lambda () - (splice-arg (call-with-output-string - (lambda (p) (display (slib:eval (read port)) p)))))) - (define backslash - (lambda (goto) - (readc) - (let ((c (readc))) - (cond ((eqv? #\newline c) (goto (peekc))) - ((and (char-whitespace? c) (eqv? #\newline (peekc)) - (eqv? 13 (char->integer c))) - (readc) (goto (peekc))) - (else (set! chars (cons c chars)) (build-token (peekc))))))) - (define loop - (lambda (c) - (case c - ((#\\) (backslash loop)) - ((#\") (splice-arg (read port))) - ((#\( #\') (s-expression)) - ((#\#) (do ((c (readc) (readc))) - ((or (eof-object? c) (eqv? #\newline c)) - (if nl-term? c (loop (peekc)))))) - ((#\;) (readc)) - ((#\newline) (readc) (and (not nl-term?) (loop (peekc)))) - (else (cond ((eof-object? c) c) - ((char-whitespace? c) (readc) (loop (peekc))) - (else (build-token c))))))) - (define splice-arg - (lambda (arg) - (set! obj (string-append obj (list->string (reverse chars)) arg)) - (set! chars '()) - (build-token (peekc)))) - (define buildit - (lambda () - (readc) - (set! argv (cons (string-append obj (list->string (reverse chars))) - argv)))) - (define build-token - (lambda (c) - (case c - ((#\") (splice-arg (read port))) - ((#\() (s-expression)) - ((#\\) (backslash build-token)) - ((#\;) (buildit)) - (else (cond ((or (eof-object? c) (char-whitespace? c)) - (buildit) - (cond ((not (and nl-term? (eqv? c #\newline))) - (set! obj "") - (set! chars '()) - (loop (peekc))))) - (else (set! chars (cons (readc) chars)) - (build-token (peekc)))))))) - (let ((c (loop (peekc)))) - (cond ((and (null? argv) (eof-object? c)) c) - (else (reverse argv))))) - -(define (read-command . port) - (read-command-from-port (cond ((null? port) (current-input-port)) - ((= 1 (length port)) (car port)) - (else - (slib:error 'read-command - "Wrong Number of ARGs:" port))) - #t)) - -(define (read-options-file filename) - (call-with-input-file filename - (lambda (port) (read-command-from-port port #f)))) diff --git a/module/slib/cring.scm b/module/slib/cring.scm deleted file mode 100644 index 320b1d2d5..000000000 --- a/module/slib/cring.scm +++ /dev/null @@ -1,470 +0,0 @@ -;;;"cring.scm" Extend Scheme numerics to any commutative ring. -;Copyright (C) 1997, 1998 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'common-list-functions) -(require 'relational-database) -(require 'database-utilities) -(require 'sort) - -(define cring:db (create-database #f 'alist-table)) -(define (make-ruleset . rules) - (define name #f) - (cond ((and (not (null? rules)) (symbol? (car rules))) - (set! name (car rules)) - (set! rules (cdr rules))) - (else (set! name (gentemp)))) - (define-tables cring:db - (list name - '((op symbol) - (sub-op1 symbol) - (sub-op2 symbol)) - '((reduction expression)) - rules)) - (let ((table ((cring:db 'open-table) name #t))) - (and table - (list (table 'get 'reduction) - (table 'row:update) - table)))) -(define *ruleset* (make-ruleset 'default)) -(define (cring:define-rule . args) - (if *ruleset* - ((cadr *ruleset*) args) - (slib:warn "No ruleset in *ruleset*"))) - -(define (combined-rulesets . rulesets) - (define name #f) - (cond ((symbol? (car rulesets)) - (set! name (car rulesets)) - (set! rulesets (cdr rulesets))) - (else (set! name (gentemp)))) - (apply make-ruleset name - (apply append - (map (lambda (ruleset) (((caddr ruleset) 'row:retrieve*))) - rulesets)))) - -;;; Distribute * over + (and -) -(define distribute* - (make-ruleset - 'distribute* - `(* + identity - ,(lambda (exp1 exp2) - ;;(print 'distributing '* '+ exp1 exp2 '==>) - (apply + (map (lambda (trm) (* trm exp2)) (cdr exp1))))) - `(* - identity - ,(lambda (exp1 exp2) - ;;(print 'distributing '* '- exp1 exp2 '==>) - (apply - (map (lambda (trm) (* trm exp2)) (cdr exp1))))))) - -;;; Distribute / over + (and -) -(define distribute/ - (make-ruleset - 'distribute/ - `(/ + identity - ,(lambda (exp1 exp2) - ;;(print 'distributing '/ '+ exp1 exp2 '==>) - (apply + (map (lambda (trm) (/ trm exp2)) (cdr exp1))))) - `(/ - identity - ,(lambda (exp1 exp2) - ;;(print 'distributing '/ '- exp1 exp2 '==>) - (apply - (map (lambda (trm) (/ trm exp2)) (cdr exp1))))))) - -(define (symbol-alpha? sym) - (char-alphabetic? (string-ref (symbol->string sym) 0))) -(define (expression-< x y) - (cond ((and (number? x) (number? y)) (> x y)) ;want negatives last - ((number? x) #t) - ((number? y) #f) - ((and (symbol? x) (symbol? y)) - (cond ((eqv? (symbol-alpha? x) (symbol-alpha? y)) - (stringstring x) (symbol->string y))) - (else (symbol-alpha? x)))) - ((symbol? x) #t) - ((symbol? y) #f) - ((null? x) #t) - ((null? y) #f) - ((expression-< (car x) (car y)) #t) - ((expression-< (car y) (car x)) #f) - (else (expression-< (cdr x) (cdr y))))) -(define (expression-sort seq) (sort! seq expression-<)) - -(define number* *) -(define number+ +) -(define number- -) -(define number/ /) -(define number^ integer-expt) -(define is-term-op? (lambda (term op) (and (pair? term) (eq? op (car term))))) -;;(define (sign x) (if (positive? x) 1 (if (negative? x) -1 0))) -(define number0? zero?) -(define (zero? x) (and (number? x) (number0? x))) - -;; To convert to CR internal form, NUMBER-op all the `numbers' in the -;; argument list and remove them from the argument list. Collect the -;; remaining arguments into equivalence classes, keeping track of the -;; number of arguments in each class. The returned list is thus: -;; ( ( . ) ...) - -;;; Converts * argument list to CR internal form -(define (cr*-args->fcts args) - ;;(print (cons 'cr*-args->fcts args) '==>) - (let loop ((args args) (pow 1) (nums 1) (arg.exps '())) - ;;(print (list 'loop args pow nums denoms arg.exps) '==>) - (cond ((null? args) (cons nums arg.exps)) - ((number? (car args)) - (let ((num^pow (number^ (car args) (abs pow)))) - (if (negative? pow) - (loop (cdr args) pow (number/ (number* num^pow nums)) - arg.exps) - (loop (cdr args) pow (number* num^pow nums) arg.exps)))) - ;; Associative Rule - ((is-term-op? (car args) '*) (loop (append (cdar args) (cdr args)) - pow nums arg.exps)) - ;; Do singlet - - ((and (is-term-op? (car args) '-) (= 2 (length (car args)))) - ;;(print 'got-here (car args)) - (set! arg.exps (loop (cdar args) pow (number- nums) arg.exps)) - (loop (cdr args) pow - (car arg.exps) - (cdr arg.exps))) - ((and (is-term-op? (car args) '/) (= 2 (length (car args)))) - ;; Do singlet / - ;;(print 'got-here=cr+ (car args)) - (set! arg.exps (loop (cdar args) (number- pow) nums arg.exps)) - (loop (cdr args) pow - (car arg.exps) - (cdr arg.exps))) - ((is-term-op? (car args) '/) - ;; Do multi-arg / - ;;(print 'doing '/ (cddar args) (number- pow)) - (set! arg.exps - (loop (cddar args) (number- pow) nums arg.exps)) - ;;(print 'finishing '/ (cons (cadar args) (cdr args)) pow) - (loop (cons (cadar args) (cdr args)) - pow - (car arg.exps) - (cdr arg.exps))) - ;; Pull out numeric exponents as powers - ((and (is-term-op? (car args) '^) - (= 3 (length (car args))) - (number? (caddar args))) - (set! arg.exps (loop (list (cadar args)) - (number* pow (caddar args)) - nums - arg.exps)) - (loop (cdr args) pow (car arg.exps) (cdr arg.exps))) - ;; combine with same terms - ((assoc (car args) arg.exps) - => (lambda (pair) (set-cdr! pair (number+ pow (cdr pair))) - (loop (cdr args) pow nums arg.exps))) - ;; Add new term to arg.exps - (else (loop (cdr args) pow nums - (cons (cons (car args) pow) arg.exps)))))) - -;;; Converts + argument list to CR internal form -(define (cr+-args->trms args) - (let loop ((args args) (cof 1) (numbers 0) (arg.exps '())) - (cond ((null? args) (cons numbers arg.exps)) - ((number? (car args)) - (loop (cdr args) - cof - (number+ (number* (car args) cof) numbers) - arg.exps)) - ;; Associative Rule - ((is-term-op? (car args) '+) (loop (append (cdar args) (cdr args)) - cof - numbers - arg.exps)) - ;; Idempotent singlet * - ((and (is-term-op? (car args) '*) (= 2 (length (car args)))) - (loop (cons (cadar args) (cdr args)) - cof - numbers - arg.exps)) - ((and (is-term-op? (car args) '-) (= 2 (length (car args)))) - ;; Do singlet - - (set! arg.exps (loop (cdar args) (number- cof) numbers arg.exps)) - (loop (cdr args) cof (car arg.exps) (cdr arg.exps))) - ;; Pull out numeric factors as coefficients - ((and (is-term-op? (car args) '*) (some number? (cdar args))) - ;;(print 'got-here (car args) '=> (cons '* (remove-if number? (cdar args)))) - (set! arg.exps - (loop (list (cons '* (remove-if number? (cdar args)))) - (apply number* cof (remove-if-not number? (cdar args))) - numbers - arg.exps)) - (loop (cdr args) cof (car arg.exps) (cdr arg.exps))) - ((is-term-op? (car args) '-) - ;; Do multi-arg - - (set! arg.exps (loop (cddar args) (number- cof) numbers arg.exps)) - (loop (cons (cadar args) (cdr args)) - cof - (car arg.exps) - (cdr arg.exps))) - ;; combine with same terms - ((assoc (car args) arg.exps) - => (lambda (pair) (set-cdr! pair (number+ cof (cdr pair))) - (loop (cdr args) cof numbers arg.exps))) - ;; Add new term to arg.exps - (else (loop (cdr args) cof numbers - (cons (cons (car args) cof) arg.exps)))))) - -;;; Converts + or * internal form to Scheme expression -(define (cr-terms->form op ident inv-op higher-op res.cofs) - (define (negative-cof? fct.cof) - (negative? (cdr fct.cof))) - (define (finish exprs) - (if (null? exprs) ident - (if (null? (cdr exprs)) - (car exprs) - (cons op exprs)))) - (define (do-terms sign fct.cofs) - (expression-sort - (map (lambda (fct.cof) - (define cof (number* sign (cdr fct.cof))) - (cond ((eqv? 1 cof) (car fct.cof)) - ((number? (car fct.cof)) (number* cof (car fct.cof))) - ((is-term-op? (car fct.cof) higher-op) - (if (eq? higher-op '^) - (list '^ (cadar fct.cof) (* cof (caddar fct.cof))) - (cons higher-op (cons cof (cdar fct.cof))))) - ((eqv? -1 cof) (list inv-op (car fct.cof))) - (else (list higher-op (car fct.cof) cof)))) - fct.cofs))) - (let* ((all.cofs (remove-if (lambda (fct.cof) - (or (zero? (cdr fct.cof)) - (eqv? ident (car fct.cof)))) - res.cofs)) - (cofs (map cdr all.cofs)) - (some-positive? (some positive? cofs))) - ;;(print op 'positive? some-positive? 'negative? (some negative? cofs) all.cofs) - (cond ((and some-positive? (some negative? cofs)) - (append (list inv-op - (finish (do-terms - 1 (remove-if negative-cof? all.cofs)))) - (do-terms -1 (remove-if-not negative-cof? all.cofs)))) - (some-positive? (finish (do-terms 1 all.cofs))) - ((not (some negative? cofs)) ident) - (else (list inv-op (finish (do-terms -1 all.cofs))))))) - -(define (* . args) - (cond - ((null? args) 1) - ;;This next line is commented out so ^ will collapse numerical expressions. - ;;((null? (cdr args)) (car args)) - (else - (let ((in (cr*-args->fcts args))) - (cond - ((zero? (car in)) 0) - (else - (if (null? (cdr in)) - (set-cdr! in (list (cons 1 1)))) - (let* ((num #f) - (ans (cr-terms->form - '* 1 '/ '^ - (apply - (lambda (numeric red.cofs res.cofs) - (set! num numeric) - (append - ;;(list (cons (abs numeric) 1)) - red.cofs - res.cofs)) - (cr1 '* number* '^ '/ (car in) (cdr in)))))) - (cond ((number0? (+ -1 num)) ans) - ((number? ans) (number* num ans)) - ((number0? (+ 1 num)) - (if (and (list? ans) (= 2 (length ans)) (eq? '- (car ans))) - (cadr ans) - (list '- ans))) - ((not (pair? ans)) (list '* num ans)) - (else - (case (car ans) - ((*) (append (list '* num) (cdr ans))) - ((+) (apply + (map (lambda (mon) (* num mon)) (cdr ans)))) - ((-) (apply - (map (lambda (mon) (* num mon)) (cdr ans)))) - (else (list '* num ans)))))))))))) - -(define (+ . args) - (cond ((null? args) 0) - ;;((null? (cdr args)) (car args)) - (else - (let ((in (cr+-args->trms args))) - (if (null? (cdr in)) - (car in) - (cr-terms->form - '+ 0 '- '* - (apply (lambda (numeric red.cofs res.cofs) - (append - (list (if (and (number? numeric) - (negative? numeric)) - (cons (abs numeric) -1) - (cons numeric 1))) - red.cofs - res.cofs)) - (cr1 '+ number+ '* '- (car in) (cdr in))))))))) - -(define (- arg1 . args) - (if (null? args) - (if (number? arg1) (number- arg1) - (* -1 arg1) ;(list '- arg1) - ) - (+ arg1 (* -1 (apply + args))))) - -;;(print `(/ ,arg1 ,@args) '=> ) -(define (/ arg1 . args) - (if (null? args) - (^ arg1 -1) - (* arg1 (^ (apply * args) -1)))) - -(define (^ arg1 arg2) - (cond ((and (number? arg2) (integer? arg2)) - (* (list '^ arg1 arg2))) - (else (list '^ arg1 arg2)))) - -;; TRY-EACH-PAIR-ONCE algorithm. I think this does the minimum -;; number of rule lookups given no information about how to sort -;; terms. - -;; Pick equivalence classes one at a time and move them into the -;; result set of equivalence classes by searching for rules to -;; multiply an element of the chosen class by itself (if multiple) and -;; the element of each class already in the result group. Each -;; (multiplicative) term resulting from rule application would be put -;; in the result class, if that class exists; or put in an argument -;; class if not. - -(define (cr1 op number-op hop inv-op numeric in) - (define red.pows '()) - (define res.pows '()) - (define (cring:apply-rule->terms exp1 exp2) ;(display op) - (let ((ans (cring:apply-rule op exp1 exp2))) - (cond ((not ans) #f) - ((number? ans) (list ans)) - (else (list (cons ans 1)))))) - (define (cring:apply-inv-rule->terms exp1 exp2) ;(display inv-op) - (let ((ans (cring:apply-rule inv-op exp1 exp2))) - (cond ((not ans) #f) - ((number? ans) (list ans)) - (else (list (cons ans 1)))))) - (let loop.arg.pow.s ((arg (caar in)) (pow (cdar in)) (arg.pows (cdr in))) - (define (arg-loop arg.pows) - (cond ((not (null? arg.pows)) - (loop.arg.pow.s (caar arg.pows) (cdar arg.pows) (cdr arg.pows))) - (else (list numeric red.pows res.pows)))) ; Actually return! - (define (merge-res tmp.pows multiplicity) - (cond ((null? tmp.pows)) - ((number? (car tmp.pows)) - (do ((m (number+ -1 (abs multiplicity)) (number+ -1 m)) - (n numeric (number-op n (abs (car tmp.pows))))) - ((negative? m) (set! numeric n))) - (merge-res (cdr tmp.pows) multiplicity)) - ((or (assoc (car tmp.pows) res.pows) - (assoc (car tmp.pows) arg.pows)) - => (lambda (pair) - (set-cdr! pair (number+ - pow (number-op multiplicity (cdar tmp.pows)))) - (merge-res (cdr tmp.pows) multiplicity))) - ((assoc (car tmp.pows) red.pows) - => (lambda (pair) - (set! arg.pows - (cons (cons (caar tmp.pows) - (number+ - (cdr pair) - (number* multiplicity (cdar tmp.pows)))) - arg.pows)) - (set-cdr! pair 0) - (merge-res (cdr tmp.pows) multiplicity))) - (else (set! arg.pows - (cons (cons (caar tmp.pows) - (number* multiplicity (cdar tmp.pows))) - arg.pows)) - (merge-res (cdr tmp.pows) multiplicity)))) - (define (try-fct.pow fct.pow) - ;;(print 'try-fct.pow fct.pow op 'arg arg 'pow pow) - (cond ((or (zero? (cdr fct.pow)) (number? (car fct.pow))) #f) - ((not (and (number? pow) (number? (cdr fct.pow)) - (integer? pow) ;(integer? (cdr fct.pow)) - )) - #f) - ;;((zero? pow) (slib:error "Don't try exp-0 terms") #f) - ;;((or (number? arg) (number? (car fct.pow))) - ;; (slib:error 'found-number arg fct.pow) #f) - ((and (positive? pow) (positive? (cdr fct.pow)) - (or (cring:apply-rule->terms arg (car fct.pow)) - (cring:apply-rule->terms (car fct.pow) arg))) - => (lambda (terms) - ;;(print op op terms) - (let ((multiplicity (min pow (cdr fct.pow)))) - (set-cdr! fct.pow (number- (cdr fct.pow) multiplicity)) - (set! pow (number- pow multiplicity)) - (merge-res terms multiplicity)))) - ((and (negative? pow) (negative? (cdr fct.pow)) - (or (cring:apply-rule->terms arg (car fct.pow)) - (cring:apply-rule->terms (car fct.pow) arg))) - => (lambda (terms) - ;;(print inv-op inv-op terms) - (let ((multiplicity (max pow (cdr fct.pow)))) - (set-cdr! fct.pow (number+ (cdr fct.pow) multiplicity)) - (set! pow (number+ pow multiplicity)) - (merge-res terms multiplicity)))) - ((and (positive? pow) (negative? (cdr fct.pow)) - (cring:apply-inv-rule->terms arg (car fct.pow))) - => (lambda (terms) - ;;(print op inv-op terms) - (let ((multiplicity (min pow (number- (cdr fct.pow))))) - (set-cdr! fct.pow (number+ (cdr fct.pow) multiplicity)) - (set! pow (number- pow multiplicity)) - (merge-res terms multiplicity)))) - ((and (negative? pow) (positive? (cdr fct.pow)) - (cring:apply-inv-rule->terms (car fct.pow) arg)) - => (lambda (terms) - ;;(print inv-op op terms) - (let ((multiplicity (max (number- pow) (cdr fct.pow)))) - (set-cdr! fct.pow (number- (cdr fct.pow) multiplicity)) - (set! pow (number+ pow multiplicity)) - (merge-res terms multiplicity)))) - (else #f))) - ;;(print op numeric 'arg arg 'pow pow 'arg.pows arg.pows 'red.pows red.pows 'res.pows res.pows) - ;;(trace arg-loop cring:apply-rule->terms merge-res try-fct.pow) (set! *qp-width* 333) - (cond ((or (zero? pow) (eqv? 1 arg)) ;(number? arg) arg seems to always be 1 - (arg-loop arg.pows)) - ((assoc arg res.pows) => (lambda (pair) - (set-cdr! pair (number+ pow (cdr pair))) - (arg-loop arg.pows))) - ((and (> (abs pow) 1) (cring:apply-rule->terms arg arg)) - => (lambda (terms) - (merge-res terms (quotient pow 2)) - (if (odd? pow) - (loop.arg.pow.s arg 1 arg.pows) - (arg-loop arg.pows)))) - ((or (some try-fct.pow res.pows) (some try-fct.pow arg.pows)) - (loop.arg.pow.s arg pow arg.pows)) - (else (set! res.pows (cons (cons arg pow) res.pows)) - (arg-loop arg.pows))))) - -(define (cring:try-rule op sop1 sop2 exp1 exp2) - (and *ruleset* - (let ((rule ((car *ruleset*) op sop1 sop2))) - (and rule (rule exp1 exp2))))) - -(define (cring:apply-rule op exp1 exp2) - (and (pair? exp1) - (or (and (pair? exp2) - (cring:try-rule op (car exp1) (car exp2) exp1 exp2)) - (cring:try-rule op (car exp1) 'identity exp1 exp2)))) - -;;(begin (trace cr-terms->form) (set! *qp-width* 333)) diff --git a/module/slib/db2html.scm b/module/slib/db2html.scm deleted file mode 100644 index abfbc7326..000000000 --- a/module/slib/db2html.scm +++ /dev/null @@ -1,463 +0,0 @@ -;"db2html.scm" Convert relational database to hyperlinked pages. -; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'uri) -(require 'html-form) -(require 'net-clients) -(require 'string-search) - -;;@code{(require 'db->html)} - -;;@body -(define (html:table options . rows) - (apply string-append - (sprintf #f "\\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/module/slib/db2html.txi b/module/slib/db2html.txi deleted file mode 100644 index 0acdd46cf..000000000 --- a/module/slib/db2html.txi +++ /dev/null @@ -1,185 +0,0 @@ -@code{(require 'db->html)} - - -@defun html:table options row @dots{} - -@end defun - -@defun html:caption caption align - - -@defunx html:caption caption -@var{align} can be @samp{top} or @samp{bottom}. -@end defun - -@defun html:heading columns -Outputs a heading row for the currently-started table. -@end defun - -@defun html:href-heading columns uris -Outputs a heading row with column-names @var{columns} linked to URIs @var{uris}. -@end defun - -@defun html:linked-row-converter k foreigns - - -The positive integer @var{k} is the primary-key-limit (number of -primary-keys) of the table. @var{foreigns} is a list of the filenames of -foreign-key field pages and #f for non foreign-key fields. - -@code{html:linked-row-converter} returns a procedure taking a row for its single argument. This -returned procedure returns the html string for that table row. -@end defun - -@defun table-name->filename table-name - -Returns the symbol @var{table-name} converted to a filename. -@end defun - -@defun table->linked-html caption db table-name match-key1 @dots{} - -Returns HTML string for @var{db} table @var{table-name}. Every foreign-key value is -linked to the page (of the table) defining that key. - -The optional @var{match-key1} @dots{} arguments restrict actions to a subset of -the table. @xref{Table Operations, match-key}. -@end defun - -@defun table->linked-page db table-name index-filename arg @dots{} - -Returns a complete HTML page. The string @var{index-filename} names the page which -refers to this one. - -The optional @var{args} @dots{} arguments restrict actions to a subset of -the table. @xref{Table Operations, match-key}. -@end defun - -@defun catalog->html db caption arg @dots{} - -Returns HTML string for the catalog table of @var{db}. -@end defun -@subsection HTML editing tables - -@noindent A client can modify one row of an editable table at a time. -For any change submitted, these routines check if that row has been -modified during the time the user has been editing the form. If so, -an error page results. - -@noindent The behavior of edited rows is: - -@itemize @bullet -@item -If no fields are changed, then no change is made to the table. -@item -If the primary keys equal null-keys (parameter defaults), and no other -user has modified that row, then that row is deleted. -@item -If only primary keys are changed, there are non-key fields, and no -row with the new keys is in the table, then the old row is -deleted and one with the new keys is inserted. -@item -If only non-key fields are changed, and that row has not been -modified by another user, then the row is changed to reflect the -fields. -@item -If both keys and non-key fields are changed, and no row with the -new keys is in the table, then a row is created with the new -keys and fields. -@item -If fields are changed, all fields are primary keys, and no row with -the new keys is in the table, then a row is created with the new -keys. -@end itemize - -@noindent After any change to the table, a @code{sync-database} of the -database is performed. - - -@defun command:modify-table table-name null-keys update delete retrieve - - -@defunx command:modify-table table-name null-keys update delete - -@defunx command:modify-table table-name null-keys update - -@defunx command:modify-table table-name null-keys - -Returns procedure (of @var{db}) which returns procedure to modify row -of @var{table-name}. @var{null-keys} is the list of @dfn{null} keys which indicate that the row -@cindex null -is to be deleted. Optional arguments @var{update}, @var{delete}, and @var{retrieve} default to the -@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @var{table-name} in -@var{db}. -@end defun - -@defun command:make-editable-table rdb table-name arg @dots{} -Given @var{table-name} in @var{rdb}, creates parameter and @code{*command*} tables -for editing one row of @var{table-name} at a time. @code{command:make-editable-table} returns a procedure taking a -row argument which returns the HTML string for editing that row. - -Optional @var{args} are expressions (lists) added to the call to -@code{command:modify-table}. - -The domain name of a column determines the expected arity of the data -stored in that column. Domain names ending in: - -@table @samp -@item * -have arity @samp{nary}; -@item + -have arity @samp{nary1}. -@end table -@end defun - -@defun html:editable-row-converter k names edit-point edit-converter - - -The positive integer @var{k} is the primary-key-limit (number of -primary-keys) of the table. @var{names} is a list of the field-names. @var{edit-point} is -the list of primary-keys denoting the row to edit (or #f). @var{edit-converter} is the -procedure called with @var{k}, @var{names}, and the row to edit. - -@code{html:editable-row-converter} returns a procedure taking a row for its single argument. This -returned procedure returns the html string for that table row. - -Each HTML table constructed using @code{html:editable-row-converter} has first @var{k} fields (typically -the primary key fields) of each row linked to a text encoding of these -fields (the result of calling @code{row->anchor}). The page so -referenced typically allows the user to edit fields of that row. -@end defun -@subsection HTML databases - - -@defun db->html-files db dir index-filename caption -@var{db} must be a relational database. @var{dir} must be #f or a -non-empty string naming an existing sub-directory of the current -directory. - -@code{db->html-files} creates an html page for each table in the database @var{db} in the -sub-directory named @var{dir}, or the current directory if @var{dir} is #f. The -top level page with the catalog of tables (captioned @var{caption}) is written -to a file named @var{index-filename}. -@end defun - -@defun db->html-directory db dir index-filename - - -@defunx db->html-directory db dir -@var{db} must be a relational database. @var{dir} must be a non-empty -string naming an existing sub-directory of the current directory or -one to be created. The optional string @var{index-filename} names the filename of the -top page, which defaults to @file{index.html}. - -@code{db->html-directory} creates sub-directory @var{dir} if neccessary, and calls -@code{(db->html-files @var{db} @var{dir} @var{index-filename} @var{dir})}. The @samp{file:} URI of @var{index-filename} is -returned. -@end defun - -@defun db->netscape db dir index-filename - - -@defunx db->netscape db dir -@code{db->netscape} is just like @code{db->html-directory}, but calls -@code{browse-url-netscape} with the uri for the top page after the -pages are created. -@end defun diff --git a/module/slib/dbrowse.scm b/module/slib/dbrowse.scm deleted file mode 100644 index 082cef3e5..000000000 --- a/module/slib/dbrowse.scm +++ /dev/null @@ -1,92 +0,0 @@ -;;; "dbrowse.scm" relational-database-browser -; Copyright 1996, 1997, 1998 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'database-utilities) -(require 'printf) - -(define browse:db #f) - -(define (browse . args) - (define table-name #f) - (cond ((null? args)) - ((procedure? (car args)) - (set! browse:db (car args)) - (set! args (cdr args))) - ((string? (car args)) - (set! browse:db (open-database (car args))) - (set! args (cdr args)))) - (cond ((null? args)) - (else (set! table-name (car args)))) - (let* ((open-table (browse:db 'open-table)) - (catalog (and open-table (open-table '*catalog-data* #f)))) - (cond ((not catalog) - (slib:error 'browse "could not open catalog")) - ((not table-name) - (browse:display-dir '*catalog-data* catalog)) - (else - (let ((table (open-table table-name #f))) - (cond (table (browse:display-table table-name table) - (table 'close-table)) - (else (slib:error 'browse "could not open table" - table-name)))))))) - -(define (browse:display-dir table-name table) - (printf "%s Tables:\\n" table-name) - ((table 'for-each-row) - (lambda (row) (printf "\\t%s\\n" (car row))))) - -(define (browse:display-table table-name table) - (let* ((width 18) - (dw (string-append "%-" (number->string width))) - (dwp (string-append "%-" (number->string width) "." - (number->string (+ -1 width)))) - (dwp-string (string-append dwp "s")) - (dwp-any (string-append dwp "a")) - (dw-integer (string-append dw "d")) - (underline (string-append (make-string (+ -1 width) #\=) " ")) - (form "")) - (printf "Table: %s\\n" table-name) - (for-each (lambda (name) (printf dwp-string name)) - (table 'column-names)) - (newline) - (for-each (lambda (foreign) (printf dwp-any foreign)) - (table 'column-foreigns)) - (newline) - (for-each (lambda (domain) (printf dwp-string domain)) - (table 'column-domains)) - (newline) - (for-each (lambda (type) - (case type - ((integer number uint base-id) - (set! form (string-append form dw-integer))) - ((boolean domain expression atom) - (set! form (string-append form dwp-any))) - ((string symbol) - (set! form (string-append form dwp-string))) - (else (slib:error 'browse:display-table "unknown type" type))) - (printf dwp-string type)) - (table 'column-types)) - (newline) - (set! form (string-append form "\\n")) - (for-each (lambda (domain) (printf underline)) - (table 'column-domains)) - (newline) - ((table 'for-each-row) - (lambda (row) - (apply printf form row))))) diff --git a/module/slib/dbutil.scm b/module/slib/dbutil.scm deleted file mode 100644 index 38ab4ab40..000000000 --- a/module/slib/dbutil.scm +++ /dev/null @@ -1,313 +0,0 @@ -;;; "dbutil.scm" relational-database-utilities -; Copyright 1994, 1995, 1997, 2000, 2001 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'relational-database) -(require 'common-list-functions) - -(define (db:base-type path) - 'alist-table) ; currently the only one. - -(define (dbutil:wrap-command-interface rdb) - (and rdb - (let* ((rdms:commands ((rdb 'open-table) '*commands* #f)) - (command:get - (and rdms:commands (rdms:commands 'get 'procedure)))) - (and command:get - (letrec ((wdb (lambda (command) - (let ((com (command:get command))) - (cond (com ((slib:eval com) wdb)) - (else (rdb command))))))) - (let ((init (wdb '*initialize*))) - (if (procedure? init) init wdb))))))) - -(define (dbutil:open-database! path . arg) - (let ((type (if (null? arg) (db:base-type path) (car arg)))) - (require type) - (dbutil:wrap-command-interface - (((make-relational-system (slib:eval type)) 'open-database) - path #t)))) - -(define (dbutil:open-database path . arg) - (let ((type (if (null? arg) (db:base-type path) (car arg)))) - (require type) - (dbutil:wrap-command-interface - (((make-relational-system (slib:eval type)) 'open-database) - path #f)))) - -(define (dbutil:check-domain rdb) - (let* ((ro:domains ((rdb 'open-table) '*domains-data* #f)) - (ro:get-dir (ro:domains 'get 'domain-integrity-rule)) - (ro:for-tab (ro:domains 'get 'foreign-table))) - (lambda (domain) - (let ((fkname (ro:for-tab domain)) - (dir (slib:eval (ro:get-dir domain)))) - (if fkname (let* ((fktab ((rdb 'open-table) fkname #f)) - (p? (fktab 'get 1))) - (if dir (lambda (e) (and (dir e) (p? e))) p?)) - dir))))) - -(define (dbutil:create-database path type) - (require type) - (let ((rdb (((make-relational-system (slib:eval type)) 'create-database) - path))) - (dbutil:define-tables - rdb - '(type - ((name symbol)) - () - ((atom) - (symbol) - (string) - (number) - (money) - (date-time) - (boolean) - (foreign-key) - (expression) - (virtual))) - '(parameter-arity - ((name symbol)) - ((predicate? expression) - (procedure expression)) - ((single (lambda (a) (and (pair? a) (null? (cdr a)))) car) - (optional - (lambda (lambda (a) (or (null? a) (and (pair? a) (null? (cdr a)))))) - identity) - (boolean - (lambda (a) (or (null? a) - (and (pair? a) (null? (cdr a)) (boolean? (car a))))) - (lambda (a) (if (null? a) #f (car a)))) - (nary (lambda (a) #t) identity) - (nary1 (lambda (a) (not (null? a))) identity)))) - (for-each (((rdb 'open-table) '*domains-data* #t) 'row:insert) - '((parameter-list *catalog-data* #f symbol 1) - (parameter-name-translation *catalog-data* #f symbol 1) - (parameter-arity parameter-arity #f symbol 1) - (table *catalog-data* #f atom 1))) - (dbutil:define-tables - rdb - '(*parameter-columns* - *columns* - *columns* - ((1 #t index #f uint) - (2 #f name #f symbol) - (3 #f arity #f parameter-arity) - (4 #f domain #f domain) - (5 #f defaulter #f expression) - (6 #f expander #f expression) - (7 #f documentation #f string))) - '(no-parameters - *parameter-columns* - *parameter-columns* - ()) - '(no-parameter-names - ((name string)) - ((parameter-index uint)) - ()) - '(add-domain-params - *parameter-columns* - *parameter-columns* - ((1 domain-name single atom #f #f "new domain name") - (2 foreign-table optional table #f #f - "if present, domain-name must be existing key into this table") - (3 domain-integrity-rule optional expression #f #f - "returns #t if single argument is good") - (4 type-id single type #f #f "base type of new domain") - (5 type-param optional expression #f #f - "which (key) field of the foreign-table") - )) - '(add-domain-pnames - ((name string)) - ((parameter-index uint)) ;should be add-domain-params - ( - ("n" 1) ("name" 1) - ("f" 2) ("foreign (key) table" 2) - ("r" 3) ("domain integrity rule" 3) - ("t" 4) ("type" 4) - ("p" 5) ("type param" 5) - )) - '(del-domain-params - *parameter-columns* - *parameter-columns* - ((1 domain-name single domain #f #f "domain name"))) - '(del-domain-pnames - ((name string)) - ((parameter-index uint)) ;should be del-domain-params - (("n" 1) ("name" 1))) - '(*commands* - ((name symbol)) - ((parameters parameter-list) - (parameter-names parameter-name-translation) - (procedure expression) - (documentation string)) - ((domain-checker - no-parameters - no-parameter-names - dbutil:check-domain - "return procedure to check given domain name") - - (add-domain - add-domain-params - add-domain-pnames - (lambda (rdb) - (((rdb 'open-table) '*domains-data* #t) 'row:update)) - "add a new domain") - - (delete-domain - del-domain-params - del-domain-pnames - (lambda (rdb) - (((rdb 'open-table) '*domains-data* #t) 'row:remove)) - "delete a domain")))) - (let* ((tab ((rdb 'open-table) '*domains-data* #t)) - (row ((tab 'row:retrieve) 'type))) - (set-car! (cdr row) 'type) - ((tab 'row:update) row)) - (dbutil:wrap-command-interface rdb))) - -(define (make-defaulter arity type) - `(lambda (pl) - ',(case arity - ((optional nary) '()) - ((boolean) #f) - ((single nary1) - (case type - ((string) '("")) - ((symbol) '(nil)) - (else '(#f)))) - (else (slib:error 'make-defaulter 'unknown 'arity arity))))) - -(define (get-foreign-choices tab) - (define dlst ((tab 'get* 1))) - (do ((dlst dlst (cdr dlst)) - (vlst (if (memq 'visible-name (tab 'column-names)) - ((tab 'get* 'visible-name)) - dlst) - (cdr vlst)) - (out '() (if (member (car dlst) (cdr dlst)) - out - (cons (list (car dlst) (car vlst)) out)))) - ((null? dlst) out))) - -(define (make-command-server rdb command-table) - (let* ((comtab ((rdb 'open-table) command-table #f)) - (names (comtab 'column-names)) - (row-ref (lambda (row name) (list-ref row (position name names)))) - (comgetrow (comtab 'row:retrieve))) - (lambda (comname command-callback) - (cond ((not comname) (set! comname '*default*))) - (cond ((not (comgetrow comname)) - (slib:error 'command 'not 'known: comname))) - (let* ((command:row (comgetrow comname)) - (parameter-table - ((rdb 'open-table) (row-ref command:row 'parameters) #f)) - (parameter-names - ((rdb 'open-table) (row-ref command:row 'parameter-names) #f)) - (comval ((slib:eval (row-ref command:row 'procedure)) rdb)) - (options ((parameter-table 'get* 'name))) - (positions ((parameter-table 'get* 'index))) - (arities ((parameter-table 'get* 'arity))) - (defaulters (map slib:eval ((parameter-table 'get* 'defaulter)))) - (domains ((parameter-table 'get* 'domain))) - (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id) - domains)) - (dirs (map (rdb 'domain-checker) domains)) - (aliases - (map list ((parameter-names 'get* 'name)) - (map (parameter-table 'get 'name) - ((parameter-names 'get* 'parameter-index)))))) - (command-callback comname comval options positions - arities types defaulters dirs aliases))))) - -(define (dbutil:define-tables rdb . spec-list) - (define new-tables '()) - (define dom:typ (((rdb 'open-table) '*domains-data* #f) 'get 4)) - (define create-table (rdb 'create-table)) - (define open-table (rdb 'open-table)) - (define table-exists? (rdb 'table-exists?)) - (define (check-domain dname) - (cond ((dom:typ dname)) - ((member dname new-tables) - (let* ((ftab (open-table - (string->symbol - (string-append "desc:" (symbol->string dname))) - #f))) - ((((rdb 'open-table) '*domains-data* #t) 'row:insert) - (list dname dname #f - (dom:typ ((ftab 'get 'domain-name) 1)) 1)))))) - (define (define-table name prikeys slots data) - (cond - ((table-exists? name) - (let* ((tab (open-table name #t)) - (row:update (tab 'row:update))) - (for-each row:update data))) - ((and (symbol? prikeys) (eq? prikeys slots)) - (cond ((not (table-exists? slots)) - (slib:error "Table doesn't exist:" slots))) - (set! new-tables (cons name new-tables)) - (let* ((tab (create-table name slots)) - (row:insert (tab 'row:insert))) - (for-each row:insert data) - ((tab 'close-table)))) - (else - (let* ((descname - (string->symbol (string-append "desc:" (symbol->string name)))) - (tab (create-table descname)) - (row:insert (tab 'row:insert)) - (j 0)) - (set! new-tables (cons name new-tables)) - (for-each (lambda (des) - (set! j (+ 1 j)) - (check-domain (cadr des)) - (row:insert (list j #t (car des) - (if (null? (cddr des)) #f (caddr des)) - (cadr des)))) - prikeys) - (for-each (lambda (des) - (set! j (+ 1 j)) - (check-domain (cadr des)) - (row:insert (list j #f (car des) - (if (null? (cddr des)) #f (caddr des)) - (cadr des)))) - slots) - ((tab 'close-table)) - (set! tab (create-table name descname)) - (set! row:insert (tab 'row:insert)) - (for-each row:insert data) - ((tab 'close-table)))))) - (for-each (lambda (spec) (apply define-table spec)) spec-list)) - -(define (dbutil:list-table-definition rdb table-name) - (cond (((rdb 'table-exists?) table-name) - (let* ((table ((rdb 'open-table) table-name #f)) - (prilimit (table 'primary-limit)) - (coldefs (map list - (table 'column-names) - (table 'column-domains)))) - (list table-name - (butnthcdr prilimit coldefs) - (nthcdr prilimit coldefs) - ((table 'row:retrieve*))))) - (else #f))) - -(define create-database dbutil:create-database) -(define open-database! dbutil:open-database!) -(define open-database dbutil:open-database) -(define define-tables dbutil:define-tables) -(define list-table-definition dbutil:list-table-definition) diff --git a/module/slib/debug.scm b/module/slib/debug.scm deleted file mode 100644 index 4b50d9d53..000000000 --- a/module/slib/debug.scm +++ /dev/null @@ -1,98 +0,0 @@ -;;;; "debug.scm" Utility functions for debugging in Scheme. -;;; Copyright (C) 1991, 1992, 1993, 1995, 1999 Aubrey Jaffer. -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'trace) -(require 'break) -(require 'line-i/o) - -(define (for-each-top-level-definition-in-file file proc) - (call-with-input-file - file - (lambda (port) - (letrec - ((walk - (lambda (exp) - (cond - ((not (and (pair? exp) (list? exp)))) - ((not (symbol? (car exp)))) - (else - (case (car exp) - ((begin) (for-each walk (cdr exp))) - ((cond) (for-each - (lambda (exp) - (for-each walk - (if (list? (car exp)) exp (cdr exp)))) - (cdr exp))) - ((if) (for-each - walk (if (list? (cadr exp)) (cdr exp) (cddr exp)))) - ((defmacro define-syntax) (proc exp)) - ((define) (proc exp)))))))) - (if (eqv? #\# (peek-char port)) - (read-line port)) ;remove `magic-number' - (do ((form (read port) (read port))) - ((eof-object? form)) - (walk form)))))) - -(define (for-each-top-level-defined-procedure-symbol-in-file file proc) - (letrec ((get-defined-symbol - (lambda (form) - (if (pair? form) - (get-defined-symbol (car form)) - form)))) - (for-each-top-level-definition-in-file - file - (lambda (form) - (and (eqv? 'define (car form)) - (let ((sym (get-defined-symbol (cadr form)))) - (cond ((procedure? (slib:eval sym)) - (proc sym))))))))) - -(define (trace-all file . ...) - (for-each - (lambda (file) - (for-each-top-level-defined-procedure-symbol-in-file - file - (lambda (sym) - (slib:eval `(set! ,sym (trace:trace-procedure 'trace ,sym ',sym)))))) - (cons file ...))) -(define (track-all file . ...) - (for-each - (lambda (file) - (for-each-top-level-defined-procedure-symbol-in-file - file - (lambda (sym) - (slib:eval `(set! ,sym (trace:trace-procedure 'track ,sym ',sym)))))) - (cons file ...))) -(define (stack-all file . ...) - (for-each - (lambda (file) - (for-each-top-level-defined-procedure-symbol-in-file - file - (lambda (sym) - (slib:eval `(set! ,sym (trace:trace-procedure 'stack ,sym ',sym)))))) - (cons file ...))) - -(define (break-all file . ...) - (for-each - (lambda (file) - (for-each-top-level-defined-procedure-symbol-in-file - file - (lambda (sym) - (slib:eval `(set! ,sym (break:breakf ,sym ',sym)))))) - (cons file ...))) diff --git a/module/slib/defmacex.scm b/module/slib/defmacex.scm deleted file mode 100644 index 4c6d8bd91..000000000 --- a/module/slib/defmacex.scm +++ /dev/null @@ -1,100 +0,0 @@ -;;;"defmacex.scm" defmacro:expand* for any Scheme dialect. -;;;Copyright 1993-1994 Dorai Sitaram and Aubrey Jaffer. -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;;expand thoroughly, not just topmost expression. While expanding -;;;subexpressions, the primitive forms quote, lambda, set!, let/*/rec, -;;;cond, case, do, quasiquote: need to be destructured properly. (if, -;;;and, or, begin: don't need special treatment.) - -(define (defmacro:iqq e depth) - (letrec - ((map1 (lambda (f x) - (if (pair? x) (cons (f (car x)) (map1 f (cdr x))) - x))) - (iqq (lambda (e depth) - (if (pair? e) - (case (car e) - ((quasiquote) (list (car e) (iqq (cadr e) (+ 1 depth)))) - ((unquote unquote-splicing) - (list (car e) (if (= 1 depth) - (defmacro:expand* (cadr e)) - (iqq (cadr e) (+ -1 depth))))) - (else (map1 (lambda (e) (iqq e depth)) e))) - e)))) - (iqq e depth))) - -(define (defmacro:expand* e) - (if (pair? e) - (let* ((c (macroexpand-1 e))) - (if (not (eq? e c)) - (defmacro:expand* c) - (case (car e) - ((quote) e) - ((quasiquote) (defmacro:iqq e 0)) - ((lambda define set!) - (cons (car e) (cons (cadr e) (map defmacro:expand* (cddr e))))) - ((let) - (let ((b (cadr e))) - (if (symbol? b) ;named let - `(let ,b - ,(map (lambda (vv) - `(,(car vv) - ,(defmacro:expand* (cadr vv)))) - (caddr e)) - ,@(map defmacro:expand* - (cdddr e))) - `(let - ,(map (lambda (vv) - `(,(car vv) - ,(defmacro:expand* (cadr vv)))) - b) - ,@(map defmacro:expand* - (cddr e)))))) - ((let* letrec) - `(,(car e) ,(map (lambda (vv) - `(,(car vv) - ,(defmacro:expand* (cadr vv)))) - (cadr e)) - ,@(map defmacro:expand* (cddr e)))) - ((cond) - `(cond - ,@(map (lambda (c) - (map defmacro:expand* c)) - (cdr e)))) - ((case) - `(case ,(defmacro:expand* (cadr e)) - ,@(map (lambda (c) - `(,(car c) - ,@(map defmacro:expand* (cdr c)))) - (cddr e)))) - ((do) - `(do ,(map - (lambda (initsteps) - `(,(car initsteps) - ,@(map defmacro:expand* - (cdr initsteps)))) - (cadr e)) - ,(map defmacro:expand* (caddr e)) - ,@(map defmacro:expand* (cdddr e)))) - ((defmacro) - (cons (car e) - (cons (cadr e) - (cons (caddr e) (map defmacro:expand* (cdddr e)))))) - (else (map defmacro:expand* e))))) - e)) diff --git a/module/slib/determ.scm b/module/slib/determ.scm deleted file mode 100644 index 4b53e5f06..000000000 --- a/module/slib/determ.scm +++ /dev/null @@ -1,14 +0,0 @@ -;"determ.scm" Determinant - -(define (determinant m) - (define (butnth n lst) - (if (zero? n) (cdr lst) (cons (car lst) (butnth (+ -1 n) (cdr lst))))) - (define (minor m i j) - (map (lambda (x) (butnth j x)) (butnth i m))) - (define (cofactor m i j) - (* (if (odd? (+ i j)) -1 1) (determinant (minor m i j)))) - (define n (length m)) - (if (eqv? 1 n) (caar m) - (do ((j (+ -1 n) (+ -1 j)) - (ans 0 (+ ans (* (list-ref (car m) j) (cofactor m 0 j))))) - ((negative? j) ans)))) diff --git a/module/slib/dwindtst.scm b/module/slib/dwindtst.scm deleted file mode 100644 index 8d6480029..000000000 --- a/module/slib/dwindtst.scm +++ /dev/null @@ -1,80 +0,0 @@ -;;;; "dwindtst.scm", routines for characterizing dynamic-wind. -;Copyright (C) 1992 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'dynamic-wind) - -(define (dwtest n) - (define cont #f) - (display "testing escape from thunk") (display n) (newline) - (display "visiting:") (newline) - (call-with-current-continuation - (lambda (x) (set! cont x))) - (if n - (dynamic-wind - (lambda () - (display "thunk1") (newline) - (if (eqv? n 1) (let ((ntmp n)) - (set! n #f) - (cont ntmp)))) - (lambda () - (display "thunk2") (newline) - (if (eqv? n 2) (let ((ntmp n)) - (set! n #f) - (cont ntmp)))) - (lambda () - (display "thunk3") (newline) - (if (eqv? n 3) (let ((ntmp n)) - (set! n #f) - (cont ntmp))))))) -(define (dwctest n) - (define cont #f) - (define ccont #f) - (display "creating continuation thunk") (newline) - (display "visiting:") (newline) - (call-with-current-continuation - (lambda (x) (set! cont x))) - (if n (set! n (- n))) - (if n - (dynamic-wind - (lambda () - (display "thunk1") (newline) - (if (eqv? n 1) (let ((ntmp n)) - (set! n #f) - (cont ntmp)))) - (lambda () - (call-with-current-continuation - (lambda (x) (set! ccont x))) - (display "thunk2") (newline) - (if (eqv? n 2) (let ((ntmp n)) - (set! n #f) - (cont ntmp)))) - (lambda () - (display "thunk3") (newline) - (if (eqv? n 3) (let ((ntmp n)) - (set! n #f) - (cont ntmp)))))) - (cond - (n - (set! n (- n)) - (display "testing escape from continuation thunk") (display n) (newline) - (display "visiting:") (newline) - (ccont #f)))) - -(dwtest 1) (dwtest 2) (dwtest 3) -(dwctest 1) (dwctest 2) (dwctest 3) diff --git a/module/slib/dynamic.scm b/module/slib/dynamic.scm deleted file mode 100644 index 937f93e0e..000000000 --- a/module/slib/dynamic.scm +++ /dev/null @@ -1,75 +0,0 @@ -; "dynamic.scm", DYNAMIC data type for Scheme -; Copyright 1992 Andrew Wilcox. -; -; You may freely copy, redistribute and modify this package. - -(require 'record) -(require 'dynamic-wind) - -(define dynamic-environment-rtd - (make-record-type "dynamic environment" '(dynamic value parent))) -(define make-dynamic-environment - (record-constructor dynamic-environment-rtd)) -(define dynamic-environment:dynamic - (record-accessor dynamic-environment-rtd 'dynamic)) -(define dynamic-environment:value - (record-accessor dynamic-environment-rtd 'value)) -(define dynamic-environment:set-value! - (record-modifier dynamic-environment-rtd 'value)) -(define dynamic-environment:parent - (record-accessor dynamic-environment-rtd 'parent)) - -(define *current-dynamic-environment* #f) -(define (extend-current-dynamic-environment dynamic obj) - (set! *current-dynamic-environment* - (make-dynamic-environment dynamic obj - *current-dynamic-environment*))) - -(define dynamic-rtd (make-record-type "dynamic" '())) -(define make-dynamic - (let ((dynamic-constructor (record-constructor dynamic-rtd))) - (lambda (obj) - (let ((dynamic (dynamic-constructor))) - (extend-current-dynamic-environment dynamic obj) - dynamic)))) - -(define dynamic? (record-predicate dynamic-rtd)) -(define (guarantee-dynamic dynamic) - (or (dynamic? dynamic) - (slib:error "Not a dynamic" dynamic))) - -(define dynamic:errmsg - "No value defined for this dynamic in the current dynamic environment") - -(define (dynamic-ref dynamic) - (guarantee-dynamic dynamic) - (let loop ((env *current-dynamic-environment*)) - (cond ((not env) - (slib:error dynamic:errmsg dynamic)) - ((eq? (dynamic-environment:dynamic env) dynamic) - (dynamic-environment:value env)) - (else - (loop (dynamic-environment:parent env)))))) - -(define (dynamic-set! dynamic obj) - (guarantee-dynamic dynamic) - (let loop ((env *current-dynamic-environment*)) - (cond ((not env) - (slib:error dynamic:errmsg dynamic)) - ((eq? (dynamic-environment:dynamic env) dynamic) - (dynamic-environment:set-value! env obj)) - (else - (loop (dynamic-environment:parent env)))))) - -(define (call-with-dynamic-binding dynamic obj thunk) - (let ((out-thunk-env #f) - (in-thunk-env (make-dynamic-environment - dynamic obj - *current-dynamic-environment*))) - (dynamic-wind (lambda () - (set! out-thunk-env *current-dynamic-environment*) - (set! *current-dynamic-environment* in-thunk-env)) - thunk - (lambda () - (set! in-thunk-env *current-dynamic-environment*) - (set! *current-dynamic-environment* out-thunk-env))))) diff --git a/module/slib/dynwind.scm b/module/slib/dynwind.scm deleted file mode 100644 index 921242263..000000000 --- a/module/slib/dynwind.scm +++ /dev/null @@ -1,74 +0,0 @@ -; "dynwind.scm", wind-unwind-protect for Scheme -; Copyright (c) 1992, 1993 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;This facility is a generalization of Common Lisp `unwind-protect', -;designed to take into account the fact that continuations produced by -;CALL-WITH-CURRENT-CONTINUATION may be reentered. - -; (dynamic-wind ) procedure - -;The arguments , , and must all be procedures -;of no arguments (thunks). - -;DYNAMIC-WIND calls , , and then . The value -;returned by is returned as the result of DYNAMIC-WIND. -; is also called just before control leaves the dynamic -;context of by calling a continuation created outside that -;context. Furthermore, is called before reentering the -;dynamic context of by calling a continuation created inside -;that context. (Control is inside the context of if -;is on the current return stack). - -;;;WARNING: This code has no provision for dealing with errors or -;;;interrupts. If an error or interrupt occurs while using -;;;dynamic-wind, the dynamic environment will be that in effect at the -;;;time of the error or interrupt. - -(define dynamic:winds '()) - -(define (dynamic-wind ) - () - (set! dynamic:winds (cons (cons ) dynamic:winds)) - (let ((ans ())) - (set! dynamic:winds (cdr dynamic:winds)) - () - ans)) - -(define call-with-current-continuation - (let ((oldcc call-with-current-continuation)) - (lambda (proc) - (let ((winds dynamic:winds)) - (oldcc - (lambda (cont) - (proc (lambda (c2) - (dynamic:do-winds winds (- (length dynamic:winds) - (length winds))) - (cont c2))))))))) - -(define (dynamic:do-winds to delta) - (cond ((eq? dynamic:winds to)) - ((negative? delta) - (dynamic:do-winds (cdr to) (+ 1 delta)) - ((caar to)) - (set! dynamic:winds to)) - (else - (let ((from (cdar dynamic:winds))) - (set! dynamic:winds (cdr dynamic:winds)) - (from) - (dynamic:do-winds to (+ -1 delta)))))) diff --git a/module/slib/elk.init b/module/slib/elk.init deleted file mode 100644 index 022121c51..000000000 --- a/module/slib/elk.init +++ /dev/null @@ -1,303 +0,0 @@ -;;;"elk.init" Initialisation file for SLIB for ELK 2.1 -*- Scheme -*- -;;; Author: Aubrey Jaffer -;;; -;;; This code is in the public domain. - -; No guarantees are given about the correctness of any of the -; choices made below. Only enough work was done to get the require -; mechanism to work correctly. -; -; Stephen J. Bevan 19920912 modified by Mike -; Sperber to work correctly with statically-linked Elk and slib1d. Be -; sure to change the library vicinities according to your local -; configuration. If you're running MS-DOS (which is possible since -; 2.1), you probably have to change this file to make everything work -; correctly. - -;;; (software-type) should be set to the generic operating system type. -;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - -(define (software-type) 'UNIX) - -;;; (scheme-implementation-type) should return the name of the scheme -;;; implementation loading this file. - -(define (scheme-implementation-type) 'Elk) - -;;; (scheme-implementation-home-page) should return a (string) URI -;;; (Uniform Resource Identifier) for this scheme implementation's home -;;; page; or false if there isn't one. - -(define (scheme-implementation-home-page) - "http://www.informatik.uni-bremen.de/~net/elk/") - -;;; (scheme-implementation-version) should return a string describing -;;; the version the scheme implementation loading this file. - -(define (scheme-implementation-version) "3.0") - -;;; (implementation-vicinity) should be defined to be the pathname of -;;; the directory where any auxillary files to your Scheme -;;; implementation reside. - -(define (implementation-vicinity) - (case (software-type) - ((UNIX) "/usr/local/lib/elk-2.1/scm/") - ((VMS) "scheme$src:") - ((MS-DOS) "C:\\scheme\\"))) - -;;; (library-vicinity) should be defined to be the pathname of the -;;; directory where files of Scheme library functions reside. - -(require 'unix) -(define getenv unix-getenv) -(define system unix-system) - -(define library-vicinity - (let ((library-path - (or (getenv "SCHEME_LIBRARY_PATH") - ;; Uses this path if SCHEME_LIBRARY_PATH is not defined. - (case (software-type) - ((UNIX) "/usr/local/lib/slib/") - ((VMS) "lib$scheme:") - ((MS-DOS) "C:\\SLIB\\") - (else ""))))) - (lambda () library-path))) - -;;; (home-vicinity) should return the vicinity of the user's HOME -;;; directory, the directory which typically contains files which -;;; customize a computer environment for a user. - -(define home-vicinity - (let ((home-path (getenv "HOME"))) - (lambda () home-path))) - -;;; *features* should be set to a list of symbols describing features -;;; of this implementation. Suggestions for features are: - -(define *features* - '( - source ;can load scheme source files - ;(slib:load-source "filename") - compiled ;can load compiled files - ;(slib:load-compiled "filename") - rev4-report - ieee-p1178 - sicp - rev4-optional-procedures - rev3-procedures - rev2-procedures - multiarg/and- - multiarg-apply - delay - transcript - full-continuation - sort - format - system - getenv - program-arguments - string-port - )) - -;------------ - -(define program-arguments - (lambda () - (cons "undefined-program-name" (command-line-args)))) - -; EXACT? appears to always return #f which isn't very useful. -; Approximating it with INTEGER? at least means that some -; of the code in the library will work correctly - -(define exact? integer?) ; WARNING: redefining EXACT? - -(define (inexact? arg) - (not (exact? arg))) - -;;; (TMPNAM) makes a temporary file name. -(define tmpnam - (let ((cntr 100)) - (lambda () (set! cntr (+ 1 cntr)) - (let ((tmp (string-append "slib_" (number->string cntr)))) - (if (file-exists? tmp) (tmpnam) tmp))))) - -; Pull in GENTENV and SYSTEM - -;;; (FILE-EXISTS? ) already here. - -;;; (DELETE-FILE ) -(define (delete-file f) (system (string-append "rm " f))) - -;------------ - -;;; (OUTPUT-PORT-WIDTH ) -(define (output-port-width . arg) 79) - -;;; (OUTPUT-PORT-HEIGHT ) -(define (output-port-height . arg) 24) - -;;; (CURRENT-ERROR-PORT) -;;; is already defined in Elk 2.1 - -;;; FORCE-OUTPUT flushes any pending output on optional arg output port -;;; use this definition if your system doesn't have such a procedure. -(define force-output flush-output-port) - -;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string -;;; port versions of CALL-WITH-*PUT-FILE. -(define (call-with-output-string f) - (let ((outsp (open-output-string))) - (f outsp) - (let ((s (get-output-string outsp))) - (close-output-port outsp) - s))) - -(define (call-with-input-string s f) - (let* ((insp (open-input-string s)) - (res (f insp))) - (close-input-port insp) - res)) - -;;; CHAR-CODE-LIMIT is one greater than the largest integer which can -;;; be returned by CHAR->INTEGER. -(define char-code-limit 256) - -;;; MOST-POSITIVE-FIXNUM is used in modular.scm -(define most-positive-fixnum 8388608) ; 23 bit integers ? - -;;; Return argument -(define (identity x) x) - -;;; SLIB:EVAL is single argument eval using the top-level (user) environment. -(define slib:eval eval) - -(define *macros* '()) -(define (defmacro? m) (and (assq m *macros*) #t)) - -(define-macro (defmacro key pattern . body) - `(begin - (define-macro ,(cons key pattern) ,@body) - (set! *macros* (cons (cons ',key (lambda ,pattern ,@body)) *macros*)))) - -(define (macroexpand-1 e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) (set! a (assq a *macros*)) - (if a (apply (cdr a) (cdr e)) e)) - (else e))) - e)) - -(define (macroexpand e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) - (set! a (assq a *macros*)) - (if a (macroexpand (apply (cdr a) (cdr e))) e)) - (else e))) - e)) - -(define gentemp - (let ((*gensym-counter* -1)) - (lambda () - (set! *gensym-counter* (+ *gensym-counter* 1)) - (string->symbol - (string-append "slib:G" (number->string *gensym-counter*)))))) - -(define defmacro:eval slib:eval) -(define defmacro:load load) -;;; If your implementation provides R4RS macros: -;(define macro:eval slib:eval) -;(define macro:load load) - -(define (slib:eval-load evl) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (call-with-input-file - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* ) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - -(define slib:warn - (lambda args - (let ((cep (current-error-port))) - (if (provided? 'trace) (print-call-stack cep)) - (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) - -;;; define an error procedure for the library -(define slib:error - (lambda args -(define (slib:error . args) - (if (provided? 'trace) (print-call-stack (current-error-port))) - (apply s48-error args)) - (let ((port (open-output-string)) - (err (if (and (pair? args) (symbol? (car args))) - (car args) 'slib)) - (args (if (and (pair? args) (symbol? (car args))) - (cdr args) args))) - (for-each (lambda (x) (display x port) (display " " port)) args) - (let ((str (get-output-string port))) - (close-output-port port) - (error err str))))) - -;;; define these as appropriate for your system. -(define slib:tab #\tab) -(define slib:form-feed #\formfeed) - -;;; Define these if your implementation's syntax can support it and if -;;; they are not already defined. - -;(define (1+ n) (+ n 1)) -;(define (-1+ n) (+ n -1)) -;(define 1- -1+) - -(define in-vicinity string-append) - -;;; Define SLIB:EXIT to be the implementation procedure to exit or -;;; return if exitting not supported. -(define slib:exit - (lambda args - (exit (cond ((null? args) 0) - ((eqv? #t (car args)) 0) - ((and (number? (car args)) (integer? (car args))) (car args)) - (else 1))))) - -;;; Here for backward compatability -(define scheme-file-suffix - (let ((suffix (case (software-type) - ((NOSVE) "_scm") - (else ".scm")))) - (lambda () suffix))) - -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever -;;; suffix all the module files in SLIB have. See feature 'SOURCE. - -; Modify the already modified _load_ so that it copes with -; environments correctly. The change involves using -; _(global-environment)_ if none is explicitly specified. -; If this is not done, definitions in files loaded by other files will -; not be loaded in the correct environment. - -(define slib:load-source - (let ((primitive-load load)) - (lambda ( . rest) - (let ((env (if (null? rest) (list (global-environment)) rest))) - (apply primitive-load env))))) - -;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced -;;; by compiling "foo.scm" if this implementation can compile files. -;;; See feature 'COMPILED. - -(define slib:load-compiled - (let ((primitive-load load)) - (lambda ( . rest) - (apply primitive-load (string->symbol (string-append name ".o")) rest)))) - -;;; At this point SLIB:LOAD must be able to load SLIB files. - -(define slib:load slib:load-source) ;WARNING: redefining LOAD - -(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/module/slib/eval.scm b/module/slib/eval.scm deleted file mode 100644 index cc4b8168c..000000000 --- a/module/slib/eval.scm +++ /dev/null @@ -1,146 +0,0 @@ -; "eval.scm", Eval proposed by Guillermo (Bill) J. Rozas for R5RS. -; Copyright (c) 1997, 1998 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;; Rather than worry over the status of all the optional procedures, -;;; just require as many as possible. - -(require 'rev4-optional-procedures) -(require 'dynamic-wind) -(require 'transcript) -(require 'with-file) -(require 'values) - -(define eval:make-environment - (let ((eval-1 slib:eval)) - (lambda (identifiers) - ((lambda args args) - #f - identifiers - (lambda (expression) - (eval-1 `(lambda ,identifiers ,expression))))))) - -(define eval:capture-environment! - (let ((set-car! set-car!) - (eval-1 slib:eval) - (apply apply)) - (lambda (environment) - (set-car! - environment - (apply (lambda (environment-values identifiers procedure) - (eval-1 `((lambda args args) ,@identifiers))) - environment))))) - -(define interaction-environment - (let ((env (eval:make-environment '()))) - (lambda () env))) - -;;; null-environment is set by first call to scheme-report-environment at -;;; the end of this file. -(define null-environment #f) - -(define scheme-report-environment - (let* ((r4rs-procedures - (append - (cond ((provided? 'inexact) - (append - '(acos angle asin atan cos exact->inexact exp - expt imag-part inexact->exact log magnitude - make-polar make-rectangular real-part sin - sqrt tan) - (if (let ((n (string->number "1/3"))) - (and (number? n) (exact? n))) - '(denominator numerator) - '()))) - (else '())) - (cond ((provided? 'rationalize) - '(rationalize)) - (else '())) - (cond ((provided? 'delay) - '(force)) - (else '())) - (cond ((provided? 'char-ready?) - '(char-ready?)) - (else '())) - '(* + - / < <= = > >= abs append apply assoc assq assv boolean? - caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar - caddar cadddr caddr cadr call-with-current-continuation - call-with-input-file call-with-output-file car cdaaar cdaadr - cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr - cdddr cddr cdr ceiling char->integer char-alphabetic? char-ci<=? - char-ci=? char-ci>? char-downcase - char-lower-case? char-numeric? char-upcase char-upper-case? - char-whitespace? char<=? char=? char>? char? - close-input-port close-output-port complex? cons - current-input-port current-output-port display eof-object? eq? - equal? eqv? even? exact? floor for-each gcd inexact? - input-port? integer->char integer? lcm length list list->string - list->vector list-ref list-tail list? load make-string - make-vector map max member memq memv min modulo negative? - newline not null? number->string number? odd? open-input-file - open-output-file output-port? pair? peek-char positive? - procedure? quotient rational? read read-char real? remainder - reverse round set-car! set-cdr! string string->list - string->number string->symbol string-append string-ci<=? - string-ci=? string-ci>? string-copy - string-fill! string-length string-ref string-set! string<=? - string=? string>? string? substring - symbol->string symbol? transcript-off transcript-on truncate - vector vector->list vector-fill! vector-length vector-ref - vector-set! vector? with-input-from-file with-output-to-file - write write-char zero? - ))) - (r5rs-procedures - (append - '(call-with-values dynamic-wind eval interaction-environment - null-environment scheme-report-environment values) - r4rs-procedures)) - (r4rs-environment (eval:make-environment r4rs-procedures)) - (r5rs-environment (eval:make-environment r4rs-procedures))) - (let ((car car)) - (lambda (version) - (cond ((car r5rs-environment)) - (else - (let ((null-env (eval:make-environment r5rs-procedures))) - (set-car! null-env (map (lambda (i) #f) r5rs-procedures)) - (set! null-environment (lambda version null-env))) - (eval:capture-environment! r4rs-environment) - (eval:capture-environment! r5rs-environment))) - (case version - ((4) r4rs-environment) - ((5) r5rs-environment) - (else (slib:error 'eval 'version version 'not 'available))))))) - -(define eval - (let ((eval-1 slib:eval) - (apply apply) - (null? null?) - (eq? eq?)) - (lambda (expression . environment) - (if (null? environment) (eval-1 expression) - (apply - (lambda (environment) - (if (eq? (interaction-environment) environment) (eval-1 expression) - (apply (lambda (environment-values identifiers procedure) - (apply (procedure expression) environment-values)) - environment))) - environment))))) -(set! slib:eval eval) - -;;; Now that all the R5RS procedures are defined, capture r5rs-environment. -(and (scheme-report-environment 5) #t) diff --git a/module/slib/factor.scm b/module/slib/factor.scm deleted file mode 100644 index f10f0d589..000000000 --- a/module/slib/factor.scm +++ /dev/null @@ -1,245 +0,0 @@ -;;;; "factor.scm" factorization, prime test and generation -;;; Copyright (C) 1991, 1992, 1993, 1998 Aubrey Jaffer. -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'common-list-functions) -(require 'modular) -(require 'random) -(require 'byte) - -;;@body -;;@0 is the random-state (@pxref{Random Numbers}) used by these -;;procedures. If you call these procedures from more than one thread -;;(or from interrupt), @code{random} may complain about reentrant -;;calls. -(define prime:prngs - (make-random-state "repeatable seed for primes")) - - -;;@emph{Note:} The prime test and generation procedures implement (or -;;use) the Solovay-Strassen primality test. See -;; -;;@itemize @bullet -;;@item Robert Solovay and Volker Strassen, -;;@cite{A Fast Monte-Carlo Test for Primality}, -;;SIAM Journal on Computing, 1977, pp 84-85. -;;@end itemize - -;;; Solovay-Strassen Prime Test -;;; if n is prime, then J(a,n) is congruent mod n to a**((n-1)/2) - -;;; (modulo p 16) is because we care only about the low order bits. -;;; The odd? tests are inline of (expt -1 ...) - -(define (prime:jacobi-symbol p q) - (cond ((zero? p) 0) - ((= 1 p) 1) - ((odd? p) - (if (odd? (quotient (* (- (modulo p 16) 1) (- q 1)) 4)) - (- (prime:jacobi-symbol (modulo q p) p)) - (prime:jacobi-symbol (modulo q p) p))) - (else - (let ((qq (modulo q 16))) - (if (odd? (quotient (- (* qq qq) 1) 8)) - (- (prime:jacobi-symbol (quotient p 2) q)) - (prime:jacobi-symbol (quotient p 2) q)))))) -;;@args p q -;;Returns the value (+1, @minus{}1, or 0) of the Jacobi-Symbol of -;;exact non-negative integer @1 and exact positive odd integer @2. -(define jacobi-symbol prime:jacobi-symbol) - -;;@body -;;@0 the maxinum number of iterations of Solovay-Strassen that will -;;be done to test a number for primality. -(define prime:trials 30) - -;;; checks if n is prime. Returns #f if not prime. #t if (probably) prime. -;;; probability of a mistake = (expt 2 (- prime:trials)) -;;; choosing prime:trials=30 should be enough -(define (Solovay-Strassen-prime? n) - (do ((i prime:trials (- i 1)) - (a (+ 2 (random (- n 2) prime:prngs)) - (+ 2 (random (- n 2) prime:prngs)))) - ((not (and (positive? i) - (= (gcd a n) 1) - (= (modulo (prime:jacobi-symbol a n) n) - (modular:expt n a (quotient (- n 1) 2))))) - (if (positive? i) #f #t)))) - -;;; prime:products are products of small primes. -(define (primes-gcd? n comps) - (comlist:notevery (lambda (prd) (= 1 (gcd n prd))) comps)) -(define prime:prime-sqr 121) -(define prime:products '(105)) -(define prime:sieve (bytes 0 0 1 1 0 1 0 1 0 0 0)) -(letrec ((lp (lambda (comp comps primes nexp) - (cond ((< comp (quotient most-positive-fixnum nexp)) - (let ((ncomp (* nexp comp))) - (lp ncomp comps - (cons nexp primes) - (next-prime nexp (cons ncomp comps))))) - ((< (quotient comp nexp) (* nexp nexp)) - (set! prime:prime-sqr (* nexp nexp)) - (set! prime:sieve (make-bytes nexp 0)) - (for-each (lambda (prime) - (byte-set! prime:sieve prime 1)) - primes) - (set! prime:products (reverse (cons comp comps)))) - (else - (lp nexp (cons comp comps) - (cons nexp primes) - (next-prime nexp (cons comp comps))))))) - (next-prime (lambda (nexp comps) - (set! comps (reverse comps)) - (do ((nexp (+ 2 nexp) (+ 2 nexp))) - ((not (primes-gcd? nexp comps)) nexp))))) - (lp 3 '() '(2 3) 5)) - -(define (prime:prime? n) - (set! n (abs n)) - (cond ((< n (bytes-length prime:sieve)) (positive? (byte-ref prime:sieve n))) - ((even? n) #f) - ((primes-gcd? n prime:products) #f) - ((< n prime:prime-sqr) #t) - (else (Solovay-Strassen-prime? n)))) -;;@args n -;;Returns @code{#f} if @1 is composite; @code{#t} if @1 is prime. -;;There is a slight chance @code{(expt 2 (- prime:trials))} that a -;;composite will return @code{#t}. -(define prime? prime:prime?) -(define probably-prime? prime:prime?) ;legacy - -(define (prime:prime< start) - (do ((nbr (+ -1 start) (+ -1 nbr))) - ((or (negative? nbr) (prime:prime? nbr)) - (if (negative? nbr) #f nbr)))) - -(define (prime:primes< start count) - (do ((cnt (+ -2 count) (+ -1 cnt)) - (lst '() (cons prime lst)) - (prime (prime:prime< start) (prime:prime< prime))) - ((or (not prime) (negative? cnt)) - (if prime (cons prime lst) lst)))) -;;@args start count -;;Returns a list of the first @2 prime numbers less than -;;@1. If there are fewer than @var{count} prime numbers -;;less than @var{start}, then the returned list will have fewer than -;;@var{start} elements. -(define primes< prime:primes<) - -(define (prime:prime> start) - (do ((nbr (+ 1 start) (+ 1 nbr))) - ((prime:prime? nbr) nbr))) - -(define (prime:primes> start count) - (set! start (max 0 start)) - (do ((cnt (+ -2 count) (+ -1 cnt)) - (lst '() (cons prime lst)) - (prime (prime:prime> start) (prime:prime> prime))) - ((negative? cnt) - (reverse (cons prime lst))))) -;;@args start count -;;Returns a list of the first @2 prime numbers greater than @1. -(define primes> prime:primes>) - -;;;;Lankinen's recursive factoring algorithm: -;From: ld231782@longs.LANCE.ColoState.EDU (L. Detweiler) - -; | undefined if n<0, -; | (u,v) if n=0, -;Let f(u,v,b,n) := | [otherwise] -; | f(u+b,v,2b,(n-v)/2) or f(u,v+b,2b,(n-u)/2) if n odd -; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even - -;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m. - -;It may be illuminating to consider the relation of the Lankinen function in -;a `computational hierarchy' of other factoring functions.* Assumptions are -;made herein on the basis of conventional digital (binary) computers. Also, -;complexity orders are given for the worst case scenarios (when the number to -;be factored is prime). However, all algorithms would probably perform to -;the same constant multiple of the given orders for complete composite -;factorizations. - -;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and -; O(n*log2(n)) in space. -;Pf: It works with all prime factors less than n (about ln(n)/n by the prime -; number thm), requiring an array of size proportional to n with log2(n) -; space for each entry. - -;Thm: `Odd factors' is O((sqrt(n)/2)*log2(n)) in time and O(log2(n)) in -; space. -;Pf: It tests all odd factors less than the square root of n (about -; sqrt(n)/2), with log2(n) time for each division. It requires only -; log2(n) space for the number and divisors. - -;Thm: Lankinen's algorithm is O(sqrt(n)/2) in time and O((sqrt(n)/2)*log2(n)) -; in space. -;Pf: The algorithm is easily modified to seach only for factors p start count - -Returns a list of the first @var{count} prime numbers greater than @var{start}. -@end defun - -@defun factor k - -Returns a list of the prime factors of @var{k}. The order of the -factors is unspecified. In order to obtain a sorted list do -@code{(sort! (factor @var{k}) <)}. -@end defun diff --git a/module/slib/fft.scm b/module/slib/fft.scm deleted file mode 100644 index 0936c1cfc..000000000 --- a/module/slib/fft.scm +++ /dev/null @@ -1,70 +0,0 @@ -;;;"fft.scm" Fast Fourier Transform -;Copyright (C) 1999 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;;; See: -;;; Introduction to Algorithms (MIT Electrical -;;; Engineering and Computer Science Series) -;;; by Thomas H. Cormen, Charles E. Leiserson (Contributor), -;;; Ronald L. Rivest (Contributor) -;;; MIT Press; ISBN: 0-262-03141-8 (July 1990) - -;;; http://www.astro.virginia.edu/~eww6n/math/DiscreteFourierTransform.html -;;; differs in the direction of rotation of the complex unit vectors. - -(require 'array) - -(define (fft:shuffled&scaled ara n scale) - (define lgn (integer-length (+ -1 n))) - (define new (apply make-array 0 (array-dimensions ara))) - (define bit-reverse (lambda (width in) - (if (zero? width) 0 - (+ (bit-reverse (+ -1 width) (quotient in 2)) - (ash (modulo in 2) (+ -1 width)))))) - (if (not (eqv? n (expt 2 lgn))) - (slib:error 'fft "array length not power of 2" n)) - (do ((k 0 (+ 1 k))) - ((>= k n) new) - (array-set! new (* (array-ref ara k) scale) (bit-reverse lgn k)))) - -(define (dft! ara n dir) - (define lgn (integer-length (+ -1 n))) - (define pi2i (* 0+8i (atan 1))) - (do ((s 1 (+ 1 s))) - ((> s lgn) ara) - (let* ((m (expt 2 s)) - (w_m (exp (* dir (/ pi2i m)))) - (m/2-1 (+ (quotient m 2) -1))) - (do ((j 0 (+ 1 j)) - (w 1 (* w w_m))) - ((> j m/2-1)) - (do ((k j (+ m k))) - ((>= k n)) - (let* ((k+m/2 (+ k m/2-1 1)) - (t (* w (array-ref ara k+m/2))) - (u (array-ref ara k))) - (array-set! ara (+ u t) k) - (array-set! ara (- u t) k+m/2))))))) - -(define (fft ara) - (define n (car (array-dimensions ara))) - (dft! (fft:shuffled&scaled ara n 1) n 1)) - -(define (fft-1 ara) - (define n (car (array-dimensions ara))) - (dft! (fft:shuffled&scaled ara n (/ n)) n -1)) diff --git a/module/slib/fluidlet.scm b/module/slib/fluidlet.scm deleted file mode 100644 index 59ba481cb..000000000 --- a/module/slib/fluidlet.scm +++ /dev/null @@ -1,40 +0,0 @@ -; "fluidlet.scm", FLUID-LET for Scheme -; Copyright (c) 1998, Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'dynamic-wind) -(require 'common-list-functions) ;MAKE-LIST - -(defmacro fluid-let (clauses . body) - (let ((ids (map car clauses)) - (new-tmps (map (lambda (x) (gentemp)) clauses)) - (old-tmps (map (lambda (x) (gentemp)) clauses))) - `(let (,@(map list new-tmps (map cadr clauses)) - ,@(map list old-tmps (make-list (length clauses) #f))) - (dynamic-wind - (lambda () - ,@(map (lambda (ot id) `(set! ,ot ,id)) - old-tmps ids) - ,@(map (lambda (id nt) `(set! ,id ,nt)) - ids new-tmps)) - (lambda () ,@body) - (lambda () - ,@(map (lambda (nt id) `(set! ,nt ,id)) - new-tmps ids) - ,@(map (lambda (id ot) `(set! ,id ,ot)) - ids old-tmps)))))) diff --git a/module/slib/fmtdoc.txi b/module/slib/fmtdoc.txi deleted file mode 100644 index 3e2adb7cc..000000000 --- a/module/slib/fmtdoc.txi +++ /dev/null @@ -1,434 +0,0 @@ - -@menu -* Format Interface:: -* Format Specification:: -@end menu - -@node Format Interface, Format Specification, Format, Format -@subsection Format Interface - -@defun format destination format-string . arguments -An almost complete implementation of Common LISP format description -according to the CL reference book @cite{Common LISP} from Guy L. -Steele, Digital Press. Backward compatible to most of the available -Scheme format implementations. - -Returns @code{#t}, @code{#f} or a string; has side effect of printing -according to @var{format-string}. If @var{destination} is @code{#t}, -the output is to the current output port and @code{#t} is returned. If -@var{destination} is @code{#f}, a formatted string is returned as the -result of the call. NEW: If @var{destination} is a string, -@var{destination} is regarded as the format string; @var{format-string} is -then the first argument and the output is returned as a string. If -@var{destination} is a number, the output is to the current error port -if available by the implementation. Otherwise @var{destination} must be -an output port and @code{#t} is returned.@refill - -@var{format-string} must be a string. In case of a formatting error -format returns @code{#f} and prints a message on the current output or -error port. Characters are output as if the string were output by the -@code{display} function with the exception of those prefixed by a tilde -(~). For a detailed description of the @var{format-string} syntax -please consult a Common LISP format reference manual. For a test suite -to verify this format implementation load @file{formatst.scm}. Please -send bug reports to @code{lutzeb@@cs.tu-berlin.de}. - -Note: @code{format} is not reentrant, i.e. only one @code{format}-call -may be executed at a time. - -@end defun - -@node Format Specification, , Format Interface, Format -@subsection Format Specification (Format version 3.0) - -Please consult a Common LISP format reference manual for a detailed -description of the format string syntax. For a demonstration of the -implemented directives see @file{formatst.scm}.@refill - -This implementation supports directive parameters and modifiers -(@code{:} and @code{@@} characters). Multiple parameters must be -separated by a comma (@code{,}). Parameters can be numerical parameters -(positive or negative), character parameters (prefixed by a quote -character (@code{'}), variable parameters (@code{v}), number of rest -arguments parameter (@code{#}), empty and default parameters. Directive -characters are case independent. The general form of a directive -is:@refill - -@noindent -@var{directive} ::= ~@{@var{directive-parameter},@}[:][@@]@var{directive-character} - -@noindent -@var{directive-parameter} ::= [ [-|+]@{0-9@}+ | '@var{character} | v | # ] - - -@subsubsection Implemented CL Format Control Directives - -Documentation syntax: Uppercase characters represent the corresponding -control directive characters. Lowercase characters represent control -directive parameter descriptions. - -@table @asis -@item @code{~A} -Any (print as @code{display} does). -@table @asis -@item @code{~@@A} -left pad. -@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}A} -full padding. -@end table -@item @code{~S} -S-expression (print as @code{write} does). -@table @asis -@item @code{~@@S} -left pad. -@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}S} -full padding. -@end table -@item @code{~D} -Decimal. -@table @asis -@item @code{~@@D} -print number sign always. -@item @code{~:D} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}D} -padding. -@end table -@item @code{~X} -Hexadecimal. -@table @asis -@item @code{~@@X} -print number sign always. -@item @code{~:X} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}X} -padding. -@end table -@item @code{~O} -Octal. -@table @asis -@item @code{~@@O} -print number sign always. -@item @code{~:O} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}O} -padding. -@end table -@item @code{~B} -Binary. -@table @asis -@item @code{~@@B} -print number sign always. -@item @code{~:B} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}B} -padding. -@end table -@item @code{~@var{n}R} -Radix @var{n}. -@table @asis -@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar}R} -padding. -@end table -@item @code{~@@R} -print a number as a Roman numeral. -@item @code{~:@@R} -print a number as an ``old fashioned'' Roman numeral. -@item @code{~:R} -print a number as an ordinal English number. -@item @code{~R} -print a number as a cardinal English number. -@item @code{~P} -Plural. -@table @asis -@item @code{~@@P} -prints @code{y} and @code{ies}. -@item @code{~:P} -as @code{~P but jumps 1 argument backward.} -@item @code{~:@@P} -as @code{~@@P but jumps 1 argument backward.} -@end table -@item @code{~C} -Character. -@table @asis -@item @code{~@@C} -prints a character as the reader can understand it (i.e. @code{#\} prefixing). -@item @code{~:C} -prints a character as emacs does (eg. @code{^C} for ASCII 03). -@end table -@item @code{~F} -Fixed-format floating-point (prints a flonum like @var{mmm.nnn}). -@table @asis -@item @code{~@var{width},@var{digits},@var{scale},@var{overflowchar},@var{padchar}F} -@item @code{~@@F} -If the number is positive a plus sign is printed. -@end table -@item @code{~E} -Exponential floating-point (prints a flonum like @var{mmm.nnn}@code{E}@var{ee}). -@table @asis -@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}E} -@item @code{~@@E} -If the number is positive a plus sign is printed. -@end table -@item @code{~G} -General floating-point (prints a flonum either fixed or exponential). -@table @asis -@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}G} -@item @code{~@@G} -If the number is positive a plus sign is printed. -@end table -@item @code{~$} -Dollars floating-point (prints a flonum in fixed with signs separated). -@table @asis -@item @code{~@var{digits},@var{scale},@var{width},@var{padchar}$} -@item @code{~@@$} -If the number is positive a plus sign is printed. -@item @code{~:@@$} -A sign is always printed and appears before the padding. -@item @code{~:$} -The sign appears before the padding. -@end table -@item @code{~%} -Newline. -@table @asis -@item @code{~@var{n}%} -print @var{n} newlines. -@end table -@item @code{~&} -print newline if not at the beginning of the output line. -@table @asis -@item @code{~@var{n}&} -prints @code{~&} and then @var{n-1} newlines. -@end table -@item @code{~|} -Page Separator. -@table @asis -@item @code{~@var{n}|} -print @var{n} page separators. -@end table -@item @code{~~} -Tilde. -@table @asis -@item @code{~@var{n}~} -print @var{n} tildes. -@end table -@item @code{~} -Continuation Line. -@table @asis -@item @code{~:} -newline is ignored, white space left. -@item @code{~@@} -newline is left, white space ignored. -@end table -@item @code{~T} -Tabulation. -@table @asis -@item @code{~@@T} -relative tabulation. -@item @code{~@var{colnum,colinc}T} -full tabulation. -@end table -@item @code{~?} -Indirection (expects indirect arguments as a list). -@table @asis -@item @code{~@@?} -extracts indirect arguments from format arguments. -@end table -@item @code{~(@var{str}~)} -Case conversion (converts by @code{string-downcase}). -@table @asis -@item @code{~:(@var{str}~)} -converts by @code{string-capitalize}. -@item @code{~@@(@var{str}~)} -converts by @code{string-capitalize-first}. -@item @code{~:@@(@var{str}~)} -converts by @code{string-upcase}. -@end table -@item @code{~*} -Argument Jumping (jumps 1 argument forward). -@table @asis -@item @code{~@var{n}*} -jumps @var{n} arguments forward. -@item @code{~:*} -jumps 1 argument backward. -@item @code{~@var{n}:*} -jumps @var{n} arguments backward. -@item @code{~@@*} -jumps to the 0th argument. -@item @code{~@var{n}@@*} -jumps to the @var{n}th argument (beginning from 0) -@end table -@item @code{~[@var{str0}~;@var{str1}~;...~;@var{strn}~]} -Conditional Expression (numerical clause conditional). -@table @asis -@item @code{~@var{n}[} -take argument from @var{n}. -@item @code{~@@[} -true test conditional. -@item @code{~:[} -if-else-then conditional. -@item @code{~;} -clause separator. -@item @code{~:;} -default clause follows. -@end table -@item @code{~@{@var{str}~@}} -Iteration (args come from the next argument (a list)). -@table @asis -@item @code{~@var{n}@{} -at most @var{n} iterations. -@item @code{~:@{} -args from next arg (a list of lists). -@item @code{~@@@{} -args from the rest of arguments. -@item @code{~:@@@{} -args from the rest args (lists). -@end table -@item @code{~^} -Up and out. -@table @asis -@item @code{~@var{n}^} -aborts if @var{n} = 0 -@item @code{~@var{n},@var{m}^} -aborts if @var{n} = @var{m} -@item @code{~@var{n},@var{m},@var{k}^} -aborts if @var{n} <= @var{m} <= @var{k} -@end table -@end table - - -@subsubsection Not Implemented CL Format Control Directives - -@table @asis -@item @code{~:A} -print @code{#f} as an empty list (see below). -@item @code{~:S} -print @code{#f} as an empty list (see below). -@item @code{~<~>} -Justification. -@item @code{~:^} -(sorry I don't understand its semantics completely) -@end table - - -@subsubsection Extended, Replaced and Additional Control Directives - -@table @asis -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}D} -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}X} -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}O} -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}B} -@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar},@var{commawidth}R} -@var{commawidth} is the number of characters between two comma characters. -@end table - -@table @asis -@item @code{~I} -print a R4RS complex number as @code{~F~@@Fi} with passed parameters for -@code{~F}. -@item @code{~Y} -Pretty print formatting of an argument for scheme code lists. -@item @code{~K} -Same as @code{~?.} -@item @code{~!} -Flushes the output if format @var{destination} is a port. -@item @code{~_} -Print a @code{#\space} character -@table @asis -@item @code{~@var{n}_} -print @var{n} @code{#\space} characters. -@end table -@item @code{~/} -Print a @code{#\tab} character -@table @asis -@item @code{~@var{n}/} -print @var{n} @code{#\tab} characters. -@end table -@item @code{~@var{n}C} -Takes @var{n} as an integer representation for a character. No arguments -are consumed. @var{n} is converted to a character by -@code{integer->char}. @var{n} must be a positive decimal number.@refill -@item @code{~:S} -Print out readproof. Prints out internal objects represented as -@code{#<...>} as strings @code{"#<...>"} so that the format output can always -be processed by @code{read}. -@refill -@item @code{~:A} -Print out readproof. Prints out internal objects represented as -@code{#<...>} as strings @code{"#<...>"} so that the format output can always -be processed by @code{read}. -@item @code{~Q} -Prints information and a copyright notice on the format implementation. -@table @asis -@item @code{~:Q} -prints format version. -@end table -@refill -@item @code{~F, ~E, ~G, ~$} -may also print number strings, i.e. passing a number as a string and -format it accordingly. -@end table - -@subsubsection Configuration Variables - -Format has some configuration variables at the beginning of -@file{format.scm} to suit the systems and users needs. There should be -no modification necessary for the configuration that comes with SLIB. -If modification is desired the variable should be set after the format -code is loaded. Format detects automatically if the running scheme -system implements floating point numbers and complex numbers. - -@table @asis - -@item @var{format:symbol-case-conv} -Symbols are converted by @code{symbol->string} so the case type of the -printed symbols is implementation dependent. -@code{format:symbol-case-conv} is a one arg closure which is either -@code{#f} (no conversion), @code{string-upcase}, @code{string-downcase} -or @code{string-capitalize}. (default @code{#f}) - -@item @var{format:iobj-case-conv} -As @var{format:symbol-case-conv} but applies for the representation of -implementation internal objects. (default @code{#f}) - -@item @var{format:expch} -The character prefixing the exponent value in @code{~E} printing. (default -@code{#\E}) - -@end table - -@subsubsection Compatibility With Other Format Implementations - -@table @asis -@item SLIB format 2.x: -See @file{format.doc}. - -@item SLIB format 1.4: -Downward compatible except for padding support and @code{~A}, @code{~S}, -@code{~P}, @code{~X} uppercase printing. SLIB format 1.4 uses C-style -@code{printf} padding support which is completely replaced by the CL -@code{format} padding style. - -@item MIT C-Scheme 7.1: -Downward compatible except for @code{~}, which is not documented -(ignores all characters inside the format string up to a newline -character). (7.1 implements @code{~a}, @code{~s}, -~@var{newline}, @code{~~}, @code{~%}, numerical and variable -parameters and @code{:/@@} modifiers in the CL sense).@refill - -@item Elk 1.5/2.0: -Downward compatible except for @code{~A} and @code{~S} which print in -uppercase. (Elk implements @code{~a}, @code{~s}, @code{~~}, and -@code{~%} (no directive parameters or modifiers)).@refill - -@item Scheme->C 01nov91: -Downward compatible except for an optional destination parameter: S2C -accepts a format call without a destination which returns a formatted -string. This is equivalent to a #f destination in S2C. (S2C implements -@code{~a}, @code{~s}, @code{~c}, @code{~%}, and @code{~~} (no directive -parameters or modifiers)).@refill - -@end table - -This implementation of format is solely useful in the SLIB context -because it requires other components provided by SLIB.@refill diff --git a/module/slib/format.scm b/module/slib/format.scm deleted file mode 100644 index d9f1c86a4..000000000 --- a/module/slib/format.scm +++ /dev/null @@ -1,1675 +0,0 @@ -;;; "format.scm" Common LISP text output formatter for SLIB -; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de) -; -; This code is in the public domain. - -; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer. -; Please send error reports to the email address above. -; For documentation see slib.texi and format.doc. -; For testing load formatst.scm. -; -; Version 3.0 - -(provide 'format) -(require 'string-case) -(require 'string-port) -(require 'rev4-optional-procedures) - -;;; Configuration ------------------------------------------------------------ - -(define format:symbol-case-conv #f) -;; Symbols are converted by symbol->string so the case of the printed -;; symbols is implementation dependent. format:symbol-case-conv is a -;; one arg closure which is either #f (no conversion), string-upcase!, -;; string-downcase! or string-capitalize!. - -(define format:iobj-case-conv #f) -;; As format:symbol-case-conv but applies for the representation of -;; implementation internal objects. - -(define format:expch #\E) -;; The character prefixing the exponent value in ~e printing. - -(define format:floats (provided? 'inexact)) -;; Detects if the scheme system implements flonums (see at eof). - -(define format:complex-numbers (provided? 'complex)) -;; Detects if the scheme system implements complex numbers. - -(define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0))) -;; Detects if number->string adds a radix prefix. - -(define format:ascii-non-printable-charnames - '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" - "bs" "ht" "nl" "vt" "np" "cr" "so" "si" - "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb" - "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space")) - -;;; End of configuration ---------------------------------------------------- - -(define format:version "3.0") -(define format:port #f) ; curr. format output port -(define format:output-col 0) ; curr. format output tty column -(define format:flush-output #f) ; flush output at end of formatting -(define format:case-conversion #f) -(define format:error-continuation #f) -(define format:args #f) -(define format:pos 0) ; curr. format string parsing position -(define format:arg-pos 0) ; curr. format argument position - ; this is global for error presentation - -; format string and char output routines on format:port - -(define (format:out-str str) - (if format:case-conversion - (display (format:case-conversion str) format:port) - (display str format:port)) - (set! format:output-col - (+ format:output-col (string-length str)))) - -(define (format:out-char ch) - (if format:case-conversion - (display (format:case-conversion (string ch)) format:port) - (write-char ch format:port)) - (set! format:output-col - (if (char=? ch #\newline) - 0 - (+ format:output-col 1)))) - -;(define (format:out-substr str i n) ; this allocates a new string -; (display (substring str i n) format:port) -; (set! format:output-col (+ format:output-col n))) - -(define (format:out-substr str i n) - (do ((k i (+ k 1))) - ((= k n)) - (write-char (string-ref str k) format:port)) - (set! format:output-col (+ format:output-col n))) - -;(define (format:out-fill n ch) ; this allocates a new string -; (format:out-str (make-string n ch))) - -(define (format:out-fill n ch) - (do ((i 0 (+ i 1))) - ((= i n)) - (write-char ch format:port)) - (set! format:output-col (+ format:output-col n))) - -; format's user error handler - -(define (format:error . args) ; never returns! - (let ((error-continuation format:error-continuation) - (format-args format:args) - (port (current-error-port))) - (set! format:error format:intern-error) - (if (and (>= (length format:args) 2) - (string? (cadr format:args))) - (let ((format-string (cadr format-args))) - (if (not (zero? format:arg-pos)) - (set! format:arg-pos (- format:arg-pos 1))) - (format port "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~ - ~{~a ~}===>~{~a ~})~% " - (car format:args) - (substring format-string 0 format:pos) - (substring format-string format:pos - (string-length format-string)) - (format:list-head (cddr format:args) format:arg-pos) - (list-tail (cddr format:args) format:arg-pos))) - (format port - "~%FORMAT: error with call: (format~{ ~a~})~% " - format:args)) - (apply format port args) - (newline port) - (set! format:error format:error-save) - (set! format:error-continuation error-continuation) - (format:abort) - (format:intern-error "format:abort does not jump to toplevel!"))) - -(define format:error-save format:error) - -(define (format:intern-error . args) ;if something goes wrong in format:error - (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline) - (display " format args: ") (write format:args) (newline) - (display " error args: ") (write args) (newline) - (set! format:error format:error-save) - (format:abort)) - -(define (format:format . args) ; the formatter entry - (set! format:args args) - (set! format:arg-pos 0) - (set! format:pos 0) - (if (< (length args) 1) - (format:error "not enough arguments")) - - ;; If the first argument is a string, then that's the format string. - ;; (Scheme->C) - ;; In this case, put the argument list in canonical form. - (let ((args (if (string? (car args)) - (cons #f args) - args))) - ;; Use this canonicalized version when reporting errors. - (set! format:args args) - - (let ((destination (car args)) - (arglist (cdr args))) - (cond - ((or (and (boolean? destination) ; port output - destination) - (output-port? destination) - (number? destination)) - (format:out (cond - ((boolean? destination) (current-output-port)) - ((output-port? destination) destination) - ((number? destination) (current-error-port))) - (car arglist) (cdr arglist))) - ((and (boolean? destination) ; string output - (not destination)) - (call-with-output-string - (lambda (port) (format:out port (car arglist) (cdr arglist))))) - (else - (format:error "illegal destination `~a'" destination)))))) - -(define (format:out port fmt args) ; the output handler for a port - (set! format:port port) ; global port for output routines - (set! format:case-conversion #f) ; modifier case conversion procedure - (set! format:flush-output #f) ; ~! reset - (let ((arg-pos (format:format-work fmt args)) - (arg-len (length args))) - (cond - ((< arg-pos arg-len) - (set! format:arg-pos (+ arg-pos 1)) - (set! format:pos (string-length fmt)) - (format:error "~a superfluous argument~:p" (- arg-len arg-pos))) - ((> arg-pos arg-len) - (set! format:arg-pos (+ arg-len 1)) - (display format:arg-pos) - (format:error "~a missing argument~:p" (- arg-pos arg-len))) - (else - (if format:flush-output (force-output port)) - #t)))) - -(define format:parameter-characters - '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\')) - -(define (format:format-work format-string arglist) ; does the formatting work - (letrec - ((format-string-len (string-length format-string)) - (arg-pos 0) ; argument position in arglist - (arg-len (length arglist)) ; number of arguments - (modifier #f) ; 'colon | 'at | 'colon-at | #f - (params '()) ; directive parameter list - (param-value-found #f) ; a directive parameter value found - (conditional-nest 0) ; conditional nesting level - (clause-pos 0) ; last cond. clause beginning char pos - (clause-default #f) ; conditional default clause string - (clauses '()) ; conditional clause string list - (conditional-type #f) ; reflects the contional modifiers - (conditional-arg #f) ; argument to apply the conditional - (iteration-nest 0) ; iteration nesting level - (iteration-pos 0) ; iteration string beginning char pos - (iteration-type #f) ; reflects the iteration modifiers - (max-iterations #f) ; maximum number of iterations - (recursive-pos-save format:pos) - - (next-char ; gets the next char from format-string - (lambda () - (let ((ch (peek-next-char))) - (set! format:pos (+ 1 format:pos)) - ch))) - - (peek-next-char - (lambda () - (if (>= format:pos format-string-len) - (format:error "illegal format string") - (string-ref format-string format:pos)))) - - (one-positive-integer? - (lambda (params) - (cond - ((null? params) #f) - ((and (integer? (car params)) - (>= (car params) 0) - (= (length params) 1)) #t) - (else (format:error "one positive integer parameter expected"))))) - - (next-arg - (lambda () - (if (>= arg-pos arg-len) - (begin - (set! format:arg-pos (+ arg-len 1)) - (format:error "missing argument(s)"))) - (add-arg-pos 1) - (list-ref arglist (- arg-pos 1)))) - - (prev-arg - (lambda () - (add-arg-pos -1) - (if (negative? arg-pos) - (format:error "missing backward argument(s)")) - (list-ref arglist arg-pos))) - - (rest-args - (lambda () - (let loop ((l arglist) (k arg-pos)) ; list-tail definition - (if (= k 0) l (loop (cdr l) (- k 1)))))) - - (add-arg-pos - (lambda (n) - (set! arg-pos (+ n arg-pos)) - (set! format:arg-pos arg-pos))) - - (anychar-dispatch ; dispatches the format-string - (lambda () - (if (>= format:pos format-string-len) - arg-pos ; used for ~? continuance - (let ((char (next-char))) - (cond - ((char=? char #\~) - (set! modifier #f) - (set! params '()) - (set! param-value-found #f) - (tilde-dispatch)) - (else - (if (and (zero? conditional-nest) - (zero? iteration-nest)) - (format:out-char char)) - (anychar-dispatch))))))) - - (tilde-dispatch - (lambda () - (cond - ((>= format:pos format-string-len) - (format:out-str "~") ; tilde at end of string is just output - arg-pos) ; used for ~? continuance - ((and (or (zero? conditional-nest) - (memv (peek-next-char) ; find conditional directives - (append '(#\[ #\] #\; #\: #\@ #\^) - format:parameter-characters))) - (or (zero? iteration-nest) - (memv (peek-next-char) ; find iteration directives - (append '(#\{ #\} #\: #\@ #\^) - format:parameter-characters)))) - (case (char-upcase (next-char)) - - ;; format directives - - ((#\A) ; Any -- for humans - (set! format:read-proof (memq modifier '(colon colon-at))) - (format:out-obj-padded (memq modifier '(at colon-at)) - (next-arg) #f params) - (anychar-dispatch)) - ((#\S) ; Slashified -- for parsers - (set! format:read-proof (memq modifier '(colon colon-at))) - (format:out-obj-padded (memq modifier '(at colon-at)) - (next-arg) #t params) - (anychar-dispatch)) - ((#\D) ; Decimal - (format:out-num-padded modifier (next-arg) params 10) - (anychar-dispatch)) - ((#\X) ; Hexadecimal - (format:out-num-padded modifier (next-arg) params 16) - (anychar-dispatch)) - ((#\O) ; Octal - (format:out-num-padded modifier (next-arg) params 8) - (anychar-dispatch)) - ((#\B) ; Binary - (format:out-num-padded modifier (next-arg) params 2) - (anychar-dispatch)) - ((#\R) - (if (null? params) - (format:out-obj-padded ; Roman, cardinal, ordinal numerals - #f - ((case modifier - ((at) format:num->roman) - ((colon-at) format:num->old-roman) - ((colon) format:num->ordinal) - (else format:num->cardinal)) - (next-arg)) - #f params) - (format:out-num-padded ; any Radix - modifier (next-arg) (cdr params) (car params))) - (anychar-dispatch)) - ((#\F) ; Fixed-format floating-point - (if format:floats - (format:out-fixed modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\E) ; Exponential floating-point - (if format:floats - (format:out-expon modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\G) ; General floating-point - (if format:floats - (format:out-general modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\$) ; Dollars floating-point - (if format:floats - (format:out-dollar modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\I) ; Complex numbers - (if (not format:complex-numbers) - (format:error - "complex numbers not supported by this scheme system")) - (let ((z (next-arg))) - (if (not (complex? z)) - (format:error "argument not a complex number")) - (format:out-fixed modifier (real-part z) params) - (format:out-fixed 'at (imag-part z) params) - (format:out-char #\i)) - (anychar-dispatch)) - ((#\C) ; Character - (let ((ch (if (one-positive-integer? params) - (integer->char (car params)) - (next-arg)))) - (if (not (char? ch)) (format:error "~~c expects a character")) - (case modifier - ((at) - (format:out-str (format:char->str ch))) - ((colon) - (let ((c (char->integer ch))) - (if (< c 0) - (set! c (+ c 256))) ; compensate complement impl. - (cond - ((< c #x20) ; assumes that control chars are < #x20 - (format:out-char #\^) - (format:out-char - (integer->char (+ c #x40)))) - ((>= c #x7f) - (format:out-str "#\\") - (format:out-str - (if format:radix-pref - (let ((s (number->string c 8))) - (substring s 2 (string-length s))) - (number->string c 8)))) - (else - (format:out-char ch))))) - (else (format:out-char ch)))) - (anychar-dispatch)) - ((#\P) ; Plural - (if (memq modifier '(colon colon-at)) - (prev-arg)) - (let ((arg (next-arg))) - (if (not (number? arg)) - (format:error "~~p expects a number argument")) - (if (= arg 1) - (if (memq modifier '(at colon-at)) - (format:out-char #\y)) - (if (memq modifier '(at colon-at)) - (format:out-str "ies") - (format:out-char #\s)))) - (anychar-dispatch)) - ((#\~) ; Tilde - (if (one-positive-integer? params) - (format:out-fill (car params) #\~) - (format:out-char #\~)) - (anychar-dispatch)) - ((#\%) ; Newline - (if (one-positive-integer? params) - (format:out-fill (car params) #\newline) - (format:out-char #\newline)) - (set! format:output-col 0) - (anychar-dispatch)) - ((#\&) ; Fresh line - (if (one-positive-integer? params) - (begin - (if (> (car params) 0) - (format:out-fill (- (car params) - (if (> format:output-col 0) 0 1)) - #\newline)) - (set! format:output-col 0)) - (if (> format:output-col 0) - (format:out-char #\newline))) - (anychar-dispatch)) - ((#\_) ; Space character - (if (one-positive-integer? params) - (format:out-fill (car params) #\space) - (format:out-char #\space)) - (anychar-dispatch)) - ((#\/) ; Tabulator character - (if (one-positive-integer? params) - (format:out-fill (car params) slib:tab) - (format:out-char slib:tab)) - (anychar-dispatch)) - ((#\|) ; Page seperator - (if (one-positive-integer? params) - (format:out-fill (car params) slib:form-feed) - (format:out-char slib:form-feed)) - (set! format:output-col 0) - (anychar-dispatch)) - ((#\T) ; Tabulate - (format:tabulate modifier params) - (anychar-dispatch)) - ((#\Y) ; Pretty-print - (require 'pretty-print) - (pretty-print (next-arg) format:port) - (set! format:output-col 0) - (anychar-dispatch)) - ((#\? #\K) ; Indirection (is "~K" in T-Scheme) - (cond - ((memq modifier '(colon colon-at)) - (format:error "illegal modifier in ~~?")) - ((eq? modifier 'at) - (let* ((frmt (next-arg)) - (args (rest-args))) - (add-arg-pos (format:format-work frmt args)))) - (else - (let* ((frmt (next-arg)) - (args (next-arg))) - (format:format-work frmt args)))) - (anychar-dispatch)) - ((#\!) ; Flush output - (set! format:flush-output #t) - (anychar-dispatch)) - ((#\newline) ; Continuation lines - (if (eq? modifier 'at) - (format:out-char #\newline)) - (if (< format:pos format-string-len) - (do ((ch (peek-next-char) (peek-next-char))) - ((or (not (char-whitespace? ch)) - (= format:pos (- format-string-len 1)))) - (if (eq? modifier 'colon) - (format:out-char (next-char)) - (next-char)))) - (anychar-dispatch)) - ((#\*) ; Argument jumping - (case modifier - ((colon) ; jump backwards - (if (one-positive-integer? params) - (do ((i 0 (+ i 1))) - ((= i (car params))) - (prev-arg)) - (prev-arg))) - ((at) ; jump absolute - (set! arg-pos (if (one-positive-integer? params) - (car params) 0))) - ((colon-at) - (format:error "illegal modifier `:@' in ~~* directive")) - (else ; jump forward - (if (one-positive-integer? params) - (do ((i 0 (+ i 1))) - ((= i (car params))) - (next-arg)) - (next-arg)))) - (anychar-dispatch)) - ((#\() ; Case conversion begin - (set! format:case-conversion - (case modifier - ((at) format:string-capitalize-first) - ((colon) string-capitalize) - ((colon-at) string-upcase) - (else string-downcase))) - (anychar-dispatch)) - ((#\)) ; Case conversion end - (if (not format:case-conversion) - (format:error "missing ~~(")) - (set! format:case-conversion #f) - (anychar-dispatch)) - ((#\[) ; Conditional begin - (set! conditional-nest (+ conditional-nest 1)) - (cond - ((= conditional-nest 1) - (set! clause-pos format:pos) - (set! clause-default #f) - (set! clauses '()) - (set! conditional-type - (case modifier - ((at) 'if-then) - ((colon) 'if-else-then) - ((colon-at) (format:error "illegal modifier in ~~[")) - (else 'num-case))) - (set! conditional-arg - (if (one-positive-integer? params) - (car params) - (next-arg))))) - (anychar-dispatch)) - ((#\;) ; Conditional separator - (if (zero? conditional-nest) - (format:error "~~; not in ~~[~~] conditional")) - (if (not (null? params)) - (format:error "no parameter allowed in ~~;")) - (if (= conditional-nest 1) - (let ((clause-str - (cond - ((eq? modifier 'colon) - (set! clause-default #t) - (substring format-string clause-pos - (- format:pos 3))) - ((memq modifier '(at colon-at)) - (format:error "illegal modifier in ~~;")) - (else - (substring format-string clause-pos - (- format:pos 2)))))) - (set! clauses (append clauses (list clause-str))) - (set! clause-pos format:pos))) - (anychar-dispatch)) - ((#\]) ; Conditional end - (if (zero? conditional-nest) (format:error "missing ~~[")) - (set! conditional-nest (- conditional-nest 1)) - (if modifier - (format:error "no modifier allowed in ~~]")) - (if (not (null? params)) - (format:error "no parameter allowed in ~~]")) - (cond - ((zero? conditional-nest) - (let ((clause-str (substring format-string clause-pos - (- format:pos 2)))) - (if clause-default - (set! clause-default clause-str) - (set! clauses (append clauses (list clause-str))))) - (case conditional-type - ((if-then) - (if conditional-arg - (format:format-work (car clauses) - (list conditional-arg)))) - ((if-else-then) - (add-arg-pos - (format:format-work (if conditional-arg - (cadr clauses) - (car clauses)) - (rest-args)))) - ((num-case) - (if (or (not (integer? conditional-arg)) - (< conditional-arg 0)) - (format:error "argument not a positive integer")) - (if (not (and (>= conditional-arg (length clauses)) - (not clause-default))) - (add-arg-pos - (format:format-work - (if (>= conditional-arg (length clauses)) - clause-default - (list-ref clauses conditional-arg)) - (rest-args)))))))) - (anychar-dispatch)) - ((#\{) ; Iteration begin - (set! iteration-nest (+ iteration-nest 1)) - (cond - ((= iteration-nest 1) - (set! iteration-pos format:pos) - (set! iteration-type - (case modifier - ((at) 'rest-args) - ((colon) 'sublists) - ((colon-at) 'rest-sublists) - (else 'list))) - (set! max-iterations (if (one-positive-integer? params) - (car params) #f)))) - (anychar-dispatch)) - ((#\}) ; Iteration end - (if (zero? iteration-nest) (format:error "missing ~~{")) - (set! iteration-nest (- iteration-nest 1)) - (case modifier - ((colon) - (if (not max-iterations) (set! max-iterations 1))) - ((colon-at at) (format:error "illegal modifier")) - (else (if (not max-iterations) (set! max-iterations 100)))) - (if (not (null? params)) - (format:error "no parameters allowed in ~~}")) - (if (zero? iteration-nest) - (let ((iteration-str - (substring format-string iteration-pos - (- format:pos (if modifier 3 2))))) - (if (string=? iteration-str "") - (set! iteration-str (next-arg))) - (case iteration-type - ((list) - (let ((args (next-arg)) - (args-len 0)) - (if (not (list? args)) - (format:error "expected a list argument")) - (set! args-len (length args)) - (do ((arg-pos 0 (+ arg-pos - (format:format-work - iteration-str - (list-tail args arg-pos)))) - (i 0 (+ i 1))) - ((or (>= arg-pos args-len) - (>= i max-iterations)))))) - ((sublists) - (let ((args (next-arg)) - (args-len 0)) - (if (not (list? args)) - (format:error "expected a list argument")) - (set! args-len (length args)) - (do ((arg-pos 0 (+ arg-pos 1))) - ((or (>= arg-pos args-len) - (>= arg-pos max-iterations))) - (let ((sublist (list-ref args arg-pos))) - (if (not (list? sublist)) - (format:error - "expected a list of lists argument")) - (format:format-work iteration-str sublist))))) - ((rest-args) - (let* ((args (rest-args)) - (args-len (length args)) - (usedup-args - (do ((arg-pos 0 (+ arg-pos - (format:format-work - iteration-str - (list-tail - args arg-pos)))) - (i 0 (+ i 1))) - ((or (>= arg-pos args-len) - (>= i max-iterations)) - arg-pos)))) - (add-arg-pos usedup-args))) - ((rest-sublists) - (let* ((args (rest-args)) - (args-len (length args)) - (usedup-args - (do ((arg-pos 0 (+ arg-pos 1))) - ((or (>= arg-pos args-len) - (>= arg-pos max-iterations)) - arg-pos) - (let ((sublist (list-ref args arg-pos))) - (if (not (list? sublist)) - (format:error "expected list arguments")) - (format:format-work iteration-str sublist))))) - (add-arg-pos usedup-args))) - (else (format:error "internal error in ~~}"))))) - (anychar-dispatch)) - ((#\^) ; Up and out - (let* ((continue - (cond - ((not (null? params)) - (not - (case (length params) - ((1) (zero? (car params))) - ((2) (= (list-ref params 0) (list-ref params 1))) - ((3) (<= (list-ref params 0) - (list-ref params 1) - (list-ref params 2))) - (else (format:error "too much parameters"))))) - (format:case-conversion ; if conversion stop conversion - (set! format:case-conversion string-copy) #t) - ((= iteration-nest 1) #t) - ((= conditional-nest 1) #t) - ((>= arg-pos arg-len) - (set! format:pos format-string-len) #f) - (else #t)))) - (if continue - (anychar-dispatch)))) - - ;; format directive modifiers and parameters - - ((#\@) ; `@' modifier - (if (memq modifier '(at colon-at)) - (format:error "double `@' modifier")) - (set! modifier (if (eq? modifier 'colon) 'colon-at 'at)) - (tilde-dispatch)) - ((#\:) ; `:' modifier - (if (memq modifier '(colon colon-at)) - (format:error "double `:' modifier")) - (set! modifier (if (eq? modifier 'at) 'colon-at 'colon)) - (tilde-dispatch)) - ((#\') ; Character parameter - (if modifier (format:error "misplaced modifier")) - (set! params (append params (list (char->integer (next-char))))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr - (if modifier (format:error "misplaced modifier")) - (let ((num-str-beg (- format:pos 1)) - (num-str-end format:pos)) - (do ((ch (peek-next-char) (peek-next-char))) - ((not (char-numeric? ch))) - (next-char) - (set! num-str-end (+ 1 num-str-end))) - (set! params - (append params - (list (string->number - (substring format-string - num-str-beg - num-str-end)))))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\V) ; Variable parameter from next argum. - (if modifier (format:error "misplaced modifier")) - (set! params (append params (list (next-arg)))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\#) ; Parameter is number of remaining args - (if modifier (format:error "misplaced modifier")) - (set! params (append params (list (length (rest-args))))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\,) ; Parameter separators - (if modifier (format:error "misplaced modifier")) - (if (not param-value-found) - (set! params (append params '(#f)))) ; append empty paramtr - (set! param-value-found #f) - (tilde-dispatch)) - ((#\Q) ; Inquiry messages - (if (eq? modifier 'colon) - (format:out-str format:version) - (let ((nl (string #\newline))) - (format:out-str - (string-append - "SLIB Common LISP format version " format:version nl - " (C) copyright 1992-1994 by Dirk Lutzebaeck" nl - " please send bug reports to `lutzeb@cs.tu-berlin.de'" - nl)))) - (anychar-dispatch)) - (else ; Unknown tilde directive - (format:error "unknown control character `~c'" - (string-ref format-string (- format:pos 1)))))) - (else (anychar-dispatch)))))) ; in case of conditional - - (set! format:pos 0) - (set! format:arg-pos 0) - (anychar-dispatch) ; start the formatting - (set! format:pos recursive-pos-save) - arg-pos)) ; return the position in the arg. list - -;; format:obj->str returns a R4RS representation as a string of an arbitrary -;; scheme object. -;; First parameter is the object, second parameter is a boolean if the -;; representation should be slashified as `write' does. -;; It uses format:char->str which converts a character into -;; a slashified string as `write' does and which is implementation dependent. -;; It uses format:iobj->str to print out internal objects as -;; quoted strings so that the output can always be processed by (read) - -(define (format:obj->str obj slashify) - (cond - ((string? obj) - (if slashify - (let ((obj-len (string-length obj))) - (string-append - "\"" - (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm - (if (= j obj-len) - (string-append (substring obj i j) "\"") - (let ((c (string-ref obj j))) - (if (or (char=? c #\\) - (char=? c #\")) - (string-append (substring obj i j) "\\" - (loop j (+ j 1))) - (loop i (+ j 1)))))))) - obj)) - - ((boolean? obj) (if obj "#t" "#f")) - - ((number? obj) (number->string obj)) - - ((symbol? obj) - (if format:symbol-case-conv - (format:symbol-case-conv (symbol->string obj)) - (symbol->string obj))) - - ((char? obj) - (if slashify - (format:char->str obj) - (string obj))) - - ((null? obj) "()") - - ((input-port? obj) - (format:iobj->str obj)) - - ((output-port? obj) - (format:iobj->str obj)) - - ((list? obj) - (string-append "(" - (let loop ((obj-list obj)) - (if (null? (cdr obj-list)) - (format:obj->str (car obj-list) #t) - (string-append - (format:obj->str (car obj-list) #t) - " " - (loop (cdr obj-list))))) - ")")) - - ((pair? obj) - (string-append "(" - (format:obj->str (car obj) #t) - " . " - (format:obj->str (cdr obj) #t) - ")")) - - ((vector? obj) - (string-append "#" (format:obj->str (vector->list obj) #t))) - - (else ; only objects with an #<...> - (format:iobj->str obj)))) ; representation should fall in here - -;; format:iobj->str reveals the implementation dependent representation of -;; #<...> objects with the use of display and call-with-output-string. -;; If format:read-proof is set to #t the resulting string is additionally -;; set into string quotes. - -(define format:read-proof #f) - -(define (format:iobj->str iobj) - (if (or format:read-proof - format:iobj-case-conv) - (string-append - (if format:read-proof "\"" "") - (if format:iobj-case-conv - (format:iobj-case-conv - (call-with-output-string (lambda (p) (display iobj p)))) - (call-with-output-string (lambda (p) (display iobj p)))) - (if format:read-proof "\"" "")) - (call-with-output-string (lambda (p) (display iobj p))))) - - -;; format:char->str converts a character into a slashified string as -;; done by `write'. The procedure is dependent on the integer -;; representation of characters and assumes a character number according to -;; the ASCII character set. - -(define (format:char->str ch) - (let ((int-rep (char->integer ch))) - (if (< int-rep 0) ; if chars are [-128...+127] - (set! int-rep (+ int-rep 256))) - (string-append - "#\\" - (cond - ((char=? ch #\newline) "newline") - ((and (>= int-rep 0) (<= int-rep 32)) - (vector-ref format:ascii-non-printable-charnames int-rep)) - ((= int-rep 127) "del") - ((>= int-rep 128) ; octal representation - (if format:radix-pref - (let ((s (number->string int-rep 8))) - (substring s 2 (string-length s))) - (number->string int-rep 8))) - (else (string ch)))))) - -(define format:space-ch (char->integer #\space)) -(define format:zero-ch (char->integer #\0)) - -(define (format:par pars length index default name) - (if (> length index) - (let ((par (list-ref pars index))) - (if par - (if name - (if (< par 0) - (format:error - "~s parameter must be a positive integer" name) - par) - par) - default)) - default)) - -(define (format:out-obj-padded pad-left obj slashify pars) - (if (null? pars) - (format:out-str (format:obj->str obj slashify)) - (let ((l (length pars))) - (let ((mincol (format:par pars l 0 0 "mincol")) - (colinc (format:par pars l 1 1 "colinc")) - (minpad (format:par pars l 2 0 "minpad")) - (padchar (integer->char - (format:par pars l 3 format:space-ch #f))) - (objstr (format:obj->str obj slashify))) - (if (not pad-left) - (format:out-str objstr)) - (do ((objstr-len (string-length objstr)) - (i minpad (+ i colinc))) - ((>= (+ objstr-len i) mincol) - (format:out-fill i padchar))) - (if pad-left - (format:out-str objstr)))))) - -(define (format:out-num-padded modifier number pars radix) - (if (not (integer? number)) (format:error "argument not an integer")) - (let ((numstr (number->string number radix))) - (if (and format:radix-pref (not (= radix 10))) - (set! numstr (substring numstr 2 (string-length numstr)))) - (if (and (null? pars) (not modifier)) - (format:out-str numstr) - (let ((l (length pars)) - (numstr-len (string-length numstr))) - (let ((mincol (format:par pars l 0 #f "mincol")) - (padchar (integer->char - (format:par pars l 1 format:space-ch #f))) - (commachar (integer->char - (format:par pars l 2 (char->integer #\,) #f))) - (commawidth (format:par pars l 3 3 "commawidth"))) - (if mincol - (let ((numlen numstr-len)) ; calc. the output len of number - (if (and (memq modifier '(at colon-at)) (> number 0)) - (set! numlen (+ numlen 1))) - (if (memq modifier '(colon colon-at)) - (set! numlen (+ (quotient (- numstr-len - (if (< number 0) 2 1)) - commawidth) - numlen))) - (if (> mincol numlen) - (format:out-fill (- mincol numlen) padchar)))) - (if (and (memq modifier '(at colon-at)) - (> number 0)) - (format:out-char #\+)) - (if (memq modifier '(colon colon-at)) ; insert comma character - (let ((start (remainder numstr-len commawidth)) - (ns (if (< number 0) 1 0))) - (format:out-substr numstr 0 start) - (do ((i start (+ i commawidth))) - ((>= i numstr-len)) - (if (> i ns) - (format:out-char commachar)) - (format:out-substr numstr i (+ i commawidth)))) - (format:out-str numstr))))))) - -(define (format:tabulate modifier pars) - (let ((l (length pars))) - (let ((colnum (format:par pars l 0 1 "colnum")) - (colinc (format:par pars l 1 1 "colinc")) - (padch (integer->char (format:par pars l 2 format:space-ch #f)))) - (case modifier - ((colon colon-at) - (format:error "unsupported modifier for ~~t")) - ((at) ; relative tabulation - (format:out-fill - (if (= colinc 0) - colnum ; colnum = colrel - (do ((c 0 (+ c colinc)) - (col (+ format:output-col colnum))) - ((>= c col) - (- c format:output-col)))) - padch)) - (else ; absolute tabulation - (format:out-fill - (cond - ((< format:output-col colnum) - (- colnum format:output-col)) - ((= colinc 0) - 0) - (else - (do ((c colnum (+ c colinc))) - ((>= c format:output-col) - (- c format:output-col))))) - padch)))))) - - -;; roman numerals (from dorai@cs.rice.edu). - -(define format:roman-alist - '((1000 #\M) (500 #\D) (100 #\C) (50 #\L) - (10 #\X) (5 #\V) (1 #\I))) - -(define format:roman-boundary-values - '(100 100 10 10 1 1 #f)) - -(define format:num->old-roman - (lambda (n) - (if (and (integer? n) (>= n 1)) - (let loop ((n n) - (romans format:roman-alist) - (s '())) - (if (null? romans) (list->string (reverse s)) - (let ((roman-val (caar romans)) - (roman-dgt (cadar romans))) - (do ((q (quotient n roman-val) (- q 1)) - (s s (cons roman-dgt s))) - ((= q 0) - (loop (remainder n roman-val) - (cdr romans) s)))))) - (format:error "only positive integers can be romanized")))) - -(define format:num->roman - (lambda (n) - (if (and (integer? n) (> n 0)) - (let loop ((n n) - (romans format:roman-alist) - (boundaries format:roman-boundary-values) - (s '())) - (if (null? romans) - (list->string (reverse s)) - (let ((roman-val (caar romans)) - (roman-dgt (cadar romans)) - (bdry (car boundaries))) - (let loop2 ((q (quotient n roman-val)) - (r (remainder n roman-val)) - (s s)) - (if (= q 0) - (if (and bdry (>= r (- roman-val bdry))) - (loop (remainder r bdry) (cdr romans) - (cdr boundaries) - (cons roman-dgt - (append - (cdr (assv bdry romans)) - s))) - (loop r (cdr romans) (cdr boundaries) s)) - (loop2 (- q 1) r (cons roman-dgt s))))))) - (format:error "only positive integers can be romanized")))) - -;; cardinals & ordinals (from dorai@cs.rice.edu) - -(define format:cardinal-ones-list - '(#f "one" "two" "three" "four" "five" - "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen" - "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" - "nineteen")) - -(define format:cardinal-tens-list - '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" - "ninety")) - -(define format:num->cardinal999 - (lambda (n) - ;this procedure is inspired by the Bruno Haible's CLisp - ;function format-small-cardinal, which converts numbers - ;in the range 1 to 999, and is used for converting each - ;thousand-block in a larger number - (let* ((hundreds (quotient n 100)) - (tens+ones (remainder n 100)) - (tens (quotient tens+ones 10)) - (ones (remainder tens+ones 10))) - (append - (if (> hundreds 0) - (append - (string->list - (list-ref format:cardinal-ones-list hundreds)) - (string->list" hundred") - (if (> tens+ones 0) '(#\space) '())) - '()) - (if (< tens+ones 20) - (if (> tens+ones 0) - (string->list - (list-ref format:cardinal-ones-list tens+ones)) - '()) - (append - (string->list - (list-ref format:cardinal-tens-list tens)) - (if (> ones 0) - (cons #\- - (string->list - (list-ref format:cardinal-ones-list ones))) - '()))))))) - -(define format:cardinal-thousand-block-list - '("" " thousand" " million" " billion" " trillion" " quadrillion" - " quintillion" " sextillion" " septillion" " octillion" " nonillion" - " decillion" " undecillion" " duodecillion" " tredecillion" - " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" - " octodecillion" " novemdecillion" " vigintillion")) - -(define format:num->cardinal - (lambda (n) - (cond ((not (integer? n)) - (format:error - "only integers can be converted to English cardinals")) - ((= n 0) "zero") - ((< n 0) (string-append "minus " (format:num->cardinal (- n)))) - (else - (let ((power3-word-limit - (length format:cardinal-thousand-block-list))) - (let loop ((n n) - (power3 0) - (s '())) - (if (= n 0) - (list->string s) - (let ((n-before-block (quotient n 1000)) - (n-after-block (remainder n 1000))) - (loop n-before-block - (+ power3 1) - (if (> n-after-block 0) - (append - (if (> n-before-block 0) - (string->list ", ") '()) - (format:num->cardinal999 n-after-block) - (if (< power3 power3-word-limit) - (string->list - (list-ref - format:cardinal-thousand-block-list - power3)) - (append - (string->list " times ten to the ") - (string->list - (format:num->ordinal - (* power3 3))) - (string->list " power"))) - s) - s)))))))))) - -(define format:ordinal-ones-list - '(#f "first" "second" "third" "fourth" "fifth" - "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth" - "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth" - "eighteenth" "nineteenth")) - -(define format:ordinal-tens-list - '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" - "seventieth" "eightieth" "ninetieth")) - -(define format:num->ordinal - (lambda (n) - (cond ((not (integer? n)) - (format:error - "only integers can be converted to English ordinals")) - ((= n 0) "zeroth") - ((< n 0) (string-append "minus " (format:num->ordinal (- n)))) - (else - (let ((hundreds (quotient n 100)) - (tens+ones (remainder n 100))) - (string-append - (if (> hundreds 0) - (string-append - (format:num->cardinal (* hundreds 100)) - (if (= tens+ones 0) "th" " ")) - "") - (if (= tens+ones 0) "" - (if (< tens+ones 20) - (list-ref format:ordinal-ones-list tens+ones) - (let ((tens (quotient tens+ones 10)) - (ones (remainder tens+ones 10))) - (if (= ones 0) - (list-ref format:ordinal-tens-list tens) - (string-append - (list-ref format:cardinal-tens-list tens) - "-" - (list-ref format:ordinal-ones-list ones)))) - )))))))) - -;; format fixed flonums (~F) - -(define (format:out-fixed modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number or a number string")) - - (let ((l (length pars))) - (let ((width (format:par pars l 0 #f "width")) - (digits (format:par pars l 1 #f "digits")) - (scale (format:par pars l 2 0 #f)) - (overch (format:par pars l 3 #f #f)) - (padch (format:par pars l 4 format:space-ch #f))) - - (if digits - - (begin ; fixed precision - (format:parse-float - (if (string? number) number (number->string number)) #t scale) - (if (<= (- format:fn-len format:fn-dot) digits) - (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) - (format:fn-round digits)) - (if width - (let ((numlen (+ format:fn-len 1))) - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (and (= format:fn-dot 0) (> width (+ digits 1))) - (set! numlen (+ numlen 1))) - (if (< numlen width) - (format:out-fill (- width numlen) (integer->char padch))) - (if (and overch (> numlen width)) - (format:out-fill width (integer->char overch)) - (format:fn-out modifier (> width (+ digits 1))))) - (format:fn-out modifier #t))) - - (begin ; free precision - (format:parse-float - (if (string? number) number (number->string number)) #t scale) - (format:fn-strip) - (if width - (let ((numlen (+ format:fn-len 1))) - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (= format:fn-dot 0) - (set! numlen (+ numlen 1))) - (if (< numlen width) - (format:out-fill (- width numlen) (integer->char padch))) - (if (> numlen width) ; adjust precision if possible - (let ((dot-index (- numlen - (- format:fn-len format:fn-dot)))) - (if (> dot-index width) - (if overch ; numstr too big for required width - (format:out-fill width (integer->char overch)) - (format:fn-out modifier #t)) - (begin - (format:fn-round (- width dot-index)) - (format:fn-out modifier #t)))) - (format:fn-out modifier #t))) - (format:fn-out modifier #t))))))) - -;; format exponential flonums (~E) - -(define (format:out-expon modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number")) - - (let ((l (length pars))) - (let ((width (format:par pars l 0 #f "width")) - (digits (format:par pars l 1 #f "digits")) - (edigits (format:par pars l 2 #f "exponent digits")) - (scale (format:par pars l 3 1 #f)) - (overch (format:par pars l 4 #f #f)) - (padch (format:par pars l 5 format:space-ch #f)) - (expch (format:par pars l 6 #f #f))) - - (if digits ; fixed precision - - (let ((digits (if (> scale 0) - (if (< scale (+ digits 2)) - (+ (- digits scale) 1) - 0) - digits))) - (format:parse-float - (if (string? number) number (number->string number)) #f scale) - (if (<= (- format:fn-len format:fn-dot) digits) - (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) - (format:fn-round digits)) - (if width - (if (and edigits overch (> format:en-len edigits)) - (format:out-fill width (integer->char overch)) - (let ((numlen (+ format:fn-len 3))) ; .E+ - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (and (= format:fn-dot 0) (> width (+ digits 1))) - (set! numlen (+ numlen 1))) - (set! numlen - (+ numlen - (if (and edigits (>= edigits format:en-len)) - edigits - format:en-len))) - (if (< numlen width) - (format:out-fill (- width numlen) - (integer->char padch))) - (if (and overch (> numlen width)) - (format:out-fill width (integer->char overch)) - (begin - (format:fn-out modifier (> width (- numlen 1))) - (format:en-out edigits expch))))) - (begin - (format:fn-out modifier #t) - (format:en-out edigits expch)))) - - (begin ; free precision - (format:parse-float - (if (string? number) number (number->string number)) #f scale) - (format:fn-strip) - (if width - (if (and edigits overch (> format:en-len edigits)) - (format:out-fill width (integer->char overch)) - (let ((numlen (+ format:fn-len 3))) ; .E+ - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (= format:fn-dot 0) - (set! numlen (+ numlen 1))) - (set! numlen - (+ numlen - (if (and edigits (>= edigits format:en-len)) - edigits - format:en-len))) - (if (< numlen width) - (format:out-fill (- width numlen) - (integer->char padch))) - (if (> numlen width) ; adjust precision if possible - (let ((f (- format:fn-len format:fn-dot))) ; fract len - (if (> (- numlen f) width) - (if overch ; numstr too big for required width - (format:out-fill width - (integer->char overch)) - (begin - (format:fn-out modifier #t) - (format:en-out edigits expch))) - (begin - (format:fn-round (+ (- f numlen) width)) - (format:fn-out modifier #t) - (format:en-out edigits expch)))) - (begin - (format:fn-out modifier #t) - (format:en-out edigits expch))))) - (begin - (format:fn-out modifier #t) - (format:en-out edigits expch)))))))) - -;; format general flonums (~G) - -(define (format:out-general modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number or a number string")) - - (let ((l (length pars))) - (let ((width (if (> l 0) (list-ref pars 0) #f)) - (digits (if (> l 1) (list-ref pars 1) #f)) - (edigits (if (> l 2) (list-ref pars 2) #f)) - (overch (if (> l 4) (list-ref pars 4) #f)) - (padch (if (> l 5) (list-ref pars 5) #f))) - (format:parse-float - (if (string? number) number (number->string number)) #t 0) - (format:fn-strip) - (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm - (ww (if width (- width ee) #f)) ; see Steele's CL book p.395 - (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ? - (- (format:fn-zlead)) - format:fn-dot)) - (d (if digits - digits - (max format:fn-len (min n 7)))) ; q = format:fn-len - (dd (- d n))) - (if (<= 0 dd d) - (begin - (format:out-fixed modifier number (list ww dd #f overch padch)) - (format:out-fill ee #\space)) ;~@T not implemented yet - (format:out-expon modifier number pars)))))) - -;; format dollar flonums (~$) - -(define (format:out-dollar modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number or a number string")) - - (let ((l (length pars))) - (let ((digits (format:par pars l 0 2 "digits")) - (mindig (format:par pars l 1 1 "mindig")) - (width (format:par pars l 2 0 "width")) - (padch (format:par pars l 3 format:space-ch #f))) - - (format:parse-float - (if (string? number) number (number->string number)) #t 0) - (if (<= (- format:fn-len format:fn-dot) digits) - (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) - (format:fn-round digits)) - (let ((numlen (+ format:fn-len 1))) - (if (or (not format:fn-pos?) (memq modifier '(at colon-at))) - (set! numlen (+ numlen 1))) - (if (and mindig (> mindig format:fn-dot)) - (set! numlen (+ numlen (- mindig format:fn-dot)))) - (if (and (= format:fn-dot 0) (not mindig)) - (set! numlen (+ numlen 1))) - (if (< numlen width) - (case modifier - ((colon) - (if (not format:fn-pos?) - (format:out-char #\-)) - (format:out-fill (- width numlen) (integer->char padch))) - ((at) - (format:out-fill (- width numlen) (integer->char padch)) - (format:out-char (if format:fn-pos? #\+ #\-))) - ((colon-at) - (format:out-char (if format:fn-pos? #\+ #\-)) - (format:out-fill (- width numlen) (integer->char padch))) - (else - (format:out-fill (- width numlen) (integer->char padch)) - (if (not format:fn-pos?) - (format:out-char #\-)))) - (if format:fn-pos? - (if (memq modifier '(at colon-at)) (format:out-char #\+)) - (format:out-char #\-)))) - (if (and mindig (> mindig format:fn-dot)) - (format:out-fill (- mindig format:fn-dot) #\0)) - (if (and (= format:fn-dot 0) (not mindig)) - (format:out-char #\0)) - (format:out-substr format:fn-str 0 format:fn-dot) - (format:out-char #\.) - (format:out-substr format:fn-str format:fn-dot format:fn-len)))) - -; the flonum buffers - -(define format:fn-max 200) ; max. number of number digits -(define format:fn-str (make-string format:fn-max)) ; number buffer -(define format:fn-len 0) ; digit length of number -(define format:fn-dot #f) ; dot position of number -(define format:fn-pos? #t) ; number positive? -(define format:en-max 10) ; max. number of exponent digits -(define format:en-str (make-string format:en-max)) ; exponent buffer -(define format:en-len 0) ; digit length of exponent -(define format:en-pos? #t) ; exponent positive? - -(define (format:parse-float num-str fixed? scale) - (set! format:fn-pos? #t) - (set! format:fn-len 0) - (set! format:fn-dot #f) - (set! format:en-pos? #t) - (set! format:en-len 0) - (do ((i 0 (+ i 1)) - (left-zeros 0) - (mantissa? #t) - (all-zeros? #t) - (num-len (string-length num-str)) - (c #f)) ; current exam. character in num-str - ((= i num-len) - (if (not format:fn-dot) - (set! format:fn-dot format:fn-len)) - - (if all-zeros? - (begin - (set! left-zeros 0) - (set! format:fn-dot 0) - (set! format:fn-len 1))) - - ;; now format the parsed values according to format's need - - (if fixed? - - (begin ; fixed format m.nnn or .nnn - (if (and (> left-zeros 0) (> format:fn-dot 0)) - (if (> format:fn-dot left-zeros) - (begin ; norm 0{0}nn.mm to nn.mm - (format:fn-shiftleft left-zeros) - (set! left-zeros 0) - (set! format:fn-dot (- format:fn-dot left-zeros))) - (begin ; normalize 0{0}.nnn to .nnn - (format:fn-shiftleft format:fn-dot) - (set! left-zeros (- left-zeros format:fn-dot)) - (set! format:fn-dot 0)))) - (if (or (not (= scale 0)) (> format:en-len 0)) - (let ((shift (+ scale (format:en-int)))) - (cond - (all-zeros? #t) - ((> (+ format:fn-dot shift) format:fn-len) - (format:fn-zfill - #f (- shift (- format:fn-len format:fn-dot))) - (set! format:fn-dot format:fn-len)) - ((< (+ format:fn-dot shift) 0) - (format:fn-zfill #t (- (- shift) format:fn-dot)) - (set! format:fn-dot 0)) - (else - (if (> left-zeros 0) - (if (<= left-zeros shift) ; shift always > 0 here - (format:fn-shiftleft shift) ; shift out 0s - (begin - (format:fn-shiftleft left-zeros) - (set! format:fn-dot (- shift left-zeros)))) - (set! format:fn-dot (+ format:fn-dot shift)))))))) - - (let ((negexp ; expon format m.nnnEee - (if (> left-zeros 0) - (- left-zeros format:fn-dot -1) - (if (= format:fn-dot 0) 1 0)))) - (if (> left-zeros 0) - (begin ; normalize 0{0}.nnn to n.nn - (format:fn-shiftleft left-zeros) - (set! format:fn-dot 1)) - (if (= format:fn-dot 0) - (set! format:fn-dot 1))) - (format:en-set (- (+ (- format:fn-dot scale) (format:en-int)) - negexp)) - (cond - (all-zeros? - (format:en-set 0) - (set! format:fn-dot 1)) - ((< scale 0) ; leading zero - (format:fn-zfill #t (- scale)) - (set! format:fn-dot 0)) - ((> scale format:fn-dot) - (format:fn-zfill #f (- scale format:fn-dot)) - (set! format:fn-dot scale)) - (else - (set! format:fn-dot scale))))) - #t) - - ;; do body - (set! c (string-ref num-str i)) ; parse the output of number->string - (cond ; which can be any valid number - ((char-numeric? c) ; representation of R4RS except - (if mantissa? ; complex numbers - (begin - (if (char=? c #\0) - (if all-zeros? - (set! left-zeros (+ left-zeros 1))) - (begin - (set! all-zeros? #f))) - (string-set! format:fn-str format:fn-len c) - (set! format:fn-len (+ format:fn-len 1))) - (begin - (string-set! format:en-str format:en-len c) - (set! format:en-len (+ format:en-len 1))))) - ((or (char=? c #\-) (char=? c #\+)) - (if mantissa? - (set! format:fn-pos? (char=? c #\+)) - (set! format:en-pos? (char=? c #\+)))) - ((char=? c #\.) - (set! format:fn-dot format:fn-len)) - ((char=? c #\e) - (set! mantissa? #f)) - ((char=? c #\E) - (set! mantissa? #f)) - ((char-whitespace? c) #t) - ((char=? c #\d) #t) ; decimal radix prefix - ((char=? c #\#) #t) - (else - (format:error "illegal character `~c' in number->string" c))))) - -(define (format:en-int) ; convert exponent string to integer - (if (= format:en-len 0) - 0 - (do ((i 0 (+ i 1)) - (n 0)) - ((= i format:en-len) - (if format:en-pos? - n - (- n))) - (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i)) - format:zero-ch)))))) - -(define (format:en-set en) ; set exponent string number - (set! format:en-len 0) - (set! format:en-pos? (>= en 0)) - (let ((en-str (number->string en))) - (do ((i 0 (+ i 1)) - (en-len (string-length en-str)) - (c #f)) - ((= i en-len)) - (set! c (string-ref en-str i)) - (if (char-numeric? c) - (begin - (string-set! format:en-str format:en-len c) - (set! format:en-len (+ format:en-len 1))))))) - -(define (format:fn-zfill left? n) ; fill current number string with 0s - (if (> (+ n format:fn-len) format:fn-max) ; from the left or right - (format:error "number is too long to format (enlarge format:fn-max)")) - (set! format:fn-len (+ format:fn-len n)) - (if left? - (do ((i format:fn-len (- i 1))) ; fill n 0s to left - ((< i 0)) - (string-set! format:fn-str i - (if (< i n) - #\0 - (string-ref format:fn-str (- i n))))) - (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right - ((= i format:fn-len)) - (string-set! format:fn-str i #\0)))) - -(define (format:fn-shiftleft n) ; shift left current number n positions - (if (> n format:fn-len) - (format:error "internal error in format:fn-shiftleft (~d,~d)" - n format:fn-len)) - (do ((i n (+ i 1))) - ((= i format:fn-len) - (set! format:fn-len (- format:fn-len n))) - (string-set! format:fn-str (- i n) (string-ref format:fn-str i)))) - -(define (format:fn-round digits) ; round format:fn-str - (set! digits (+ digits format:fn-dot)) - (do ((i digits (- i 1)) ; "099",2 -> "10" - (c 5)) ; "023",2 -> "02" - ((or (= c 0) (< i 0)) ; "999",2 -> "100" - (if (= c 1) ; "005",2 -> "01" - (begin ; carry overflow - (set! format:fn-len digits) - (format:fn-zfill #t 1) ; add a 1 before fn-str - (string-set! format:fn-str 0 #\1) - (set! format:fn-dot (+ format:fn-dot 1))) - (set! format:fn-len digits))) - (set! c (+ (- (char->integer (string-ref format:fn-str i)) - format:zero-ch) c)) - (string-set! format:fn-str i (integer->char - (if (< c 10) - (+ c format:zero-ch) - (+ (- c 10) format:zero-ch)))) - (set! c (if (< c 10) 0 1)))) - -(define (format:fn-out modifier add-leading-zero?) - (if format:fn-pos? - (if (eq? modifier 'at) - (format:out-char #\+)) - (format:out-char #\-)) - (if (= format:fn-dot 0) - (if add-leading-zero? - (format:out-char #\0)) - (format:out-substr format:fn-str 0 format:fn-dot)) - (format:out-char #\.) - (format:out-substr format:fn-str format:fn-dot format:fn-len)) - -(define (format:en-out edigits expch) - (format:out-char (if expch (integer->char expch) format:expch)) - (format:out-char (if format:en-pos? #\+ #\-)) - (if edigits - (if (< format:en-len edigits) - (format:out-fill (- edigits format:en-len) #\0))) - (format:out-substr format:en-str 0 format:en-len)) - -(define (format:fn-strip) ; strip trailing zeros but one - (string-set! format:fn-str format:fn-len #\0) - (do ((i format:fn-len (- i 1))) - ((or (not (char=? (string-ref format:fn-str i) #\0)) - (<= i format:fn-dot)) - (set! format:fn-len (+ i 1))))) - -(define (format:fn-zlead) ; count leading zeros - (do ((i 0 (+ i 1))) - ((or (= i format:fn-len) - (not (char=? (string-ref format:fn-str i) #\0))) - (if (= i format:fn-len) ; found a real zero - 0 - i)))) - - -;;; some global functions not found in SLIB - -(define (format:string-capitalize-first str) ; "hello" -> "Hello" - (let ((cap-str (string-copy str)) ; "hELLO" -> "Hello" - (non-first-alpha #f) ; "*hello" -> "*Hello" - (str-len (string-length str))) ; "hello you" -> "Hello you" - (do ((i 0 (+ i 1))) - ((= i str-len) cap-str) - (let ((c (string-ref str i))) - (if (char-alphabetic? c) - (if non-first-alpha - (string-set! cap-str i (char-downcase c)) - (begin - (set! non-first-alpha #t) - (string-set! cap-str i (char-upcase c))))))))) - -(define (format:list-head l k) - (if (= k 0) - '() - (cons (car l) (format:list-head (cdr l) (- k 1))))) - - -;; Aborts the program when a formatting error occures. This is a null -;; argument closure to jump to the interpreters toplevel continuation. - -(define format:abort (lambda () (slib:error "error in format"))) - -(define format format:format) - -;; If this is not possible then a continuation is used to recover -;; properly from a format error. In this case format returns #f. - -;(define format:abort -; (lambda () (format:error-continuation #f))) - -;(define format -; (lambda args ; wraps format:format with an error -; (call-with-current-continuation ; continuation -; (lambda (cont) -; (set! format:error-continuation cont) -; (apply format:format args))))) - -;eof diff --git a/module/slib/formatst.scm b/module/slib/formatst.scm deleted file mode 100644 index 3f1913098..000000000 --- a/module/slib/formatst.scm +++ /dev/null @@ -1,647 +0,0 @@ -;; "formatst.scm" SLIB FORMAT Version 3.0 conformance test -; Written by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de) -; -; This code is in the public domain. - -;; Test run: (slib:load "formatst") - -; Failure reports for various scheme interpreters: -; -; SCM4d -; None. -; Elk 2.2: -; None. -; MIT C-Scheme 7.1: -; The empty list is always evaluated as a boolean and consequently -; represented as `#f'. -; Scheme->C 01nov91: -; None, if format:symbol-case-conv and format:iobj-case-conv are set -; to string-downcase. - -(require 'format) -(if (not (string=? format:version "3.0")) - (begin - (display "You have format version ") - (display format:version) - (display ". This test is for format version 3.0!") - (newline) - (format:abort))) - -(define fails 0) -(define total 0) -(define test-verbose #f) ; shows each test performed - -(define (test format-args out-str) - (set! total (+ total 1)) - (if (not test-verbose) - (if (zero? (modulo total 10)) - (begin - (display total) - (display ",") - (force-output (current-output-port))))) - (let ((format-out (apply format `(#f ,@format-args)))) - (if (string=? out-str format-out) - (if test-verbose - (begin - (display "Verified ") - (write format-args) - (display " returns ") - (write out-str) - (newline))) - (begin - (set! fails (+ fails 1)) - (if (not test-verbose) (newline)) - (display "*Failed* ") - (write format-args) - (newline) - (display " returns ") - (write format-out) - (newline) - (display " expected ") - (write out-str) - (newline))))) - -; ensure format default configuration - -(set! format:symbol-case-conv #f) -(set! format:iobj-case-conv #f) -(set! format:read-proof #f) - -(format #t "~q") - -(format #t "This implementation has~@[ no~] flonums ~ - ~:[but no~;and~] complex numbers~%" - (not format:floats) format:complex-numbers) - -; any object test - -(test '("abc") "abc") -(test '("~a" 10) "10") -(test '("~a" -1.2) "-1.2") -(test '("~a" a) "a") -(test '("~a" #t) "#t") -(test '("~a" #f) "#f") -(test '("~a" "abc") "abc") -(test '("~a" #(1 2 3)) "#(1 2 3)") -(test '("~a" ()) "()") -(test '("~a" (a)) "(a)") -(test '("~a" (a b)) "(a b)") -(test '("~a" (a (b c) d)) "(a (b c) d)") -(test '("~a" (a . b)) "(a . b)") -(test '("~a" (a (b c . d))) "(a (b . (c . d)))") ; this is ugly -(test `("~a" ,display) (format:iobj->str display)) -(test `("~a" ,(current-input-port)) (format:iobj->str (current-input-port))) -(test `("~a" ,(current-output-port)) (format:iobj->str (current-output-port))) - -; # argument test - -(test '("~a ~a" 10 20) "10 20") -(test '("~a abc ~a def" 10 20) "10 abc 20 def") - -; numerical test - -(test '("~d" 100) "100") -(test '("~x" 100) "64") -(test '("~o" 100) "144") -(test '("~b" 100) "1100100") -(test '("~@d" 100) "+100") -(test '("~@d" -100) "-100") -(test '("~@x" 100) "+64") -(test '("~@o" 100) "+144") -(test '("~@b" 100) "+1100100") -(test '("~10d" 100) " 100") -(test '("~:d" 123) "123") -(test '("~:d" 1234) "1,234") -(test '("~:d" 12345) "12,345") -(test '("~:d" 123456) "123,456") -(test '("~:d" 12345678) "12,345,678") -(test '("~:d" -123) "-123") -(test '("~:d" -1234) "-1,234") -(test '("~:d" -12345) "-12,345") -(test '("~:d" -123456) "-123,456") -(test '("~:d" -12345678) "-12,345,678") -(test '("~10:d" 1234) " 1,234") -(test '("~10:d" -1234) " -1,234") -(test '("~10,'*d" 100) "*******100") -(test '("~10,,'|:d" 12345678) "12|345|678") -(test '("~10,,,2:d" 12345678) "12,34,56,78") -(test '("~14,'*,'|,4:@d" 12345678) "****+1234|5678") -(test '("~10r" 100) "100") -(test '("~2r" 100) "1100100") -(test '("~8r" 100) "144") -(test '("~16r" 100) "64") -(test '("~16,10,'*r" 100) "********64") - -; roman numeral test - -(test '("~@r" 4) "IV") -(test '("~@r" 19) "XIX") -(test '("~@r" 50) "L") -(test '("~@r" 100) "C") -(test '("~@r" 1000) "M") -(test '("~@r" 99) "XCIX") -(test '("~@r" 1994) "MCMXCIV") - -; old roman numeral test - -(test '("~:@r" 4) "IIII") -(test '("~:@r" 5) "V") -(test '("~:@r" 10) "X") -(test '("~:@r" 9) "VIIII") - -; cardinal/ordinal English number test - -(test '("~r" 4) "four") -(test '("~r" 10) "ten") -(test '("~r" 19) "nineteen") -(test '("~r" 1984) "one thousand, nine hundred eighty-four") -(test '("~:r" -1984) "minus one thousand, nine hundred eighty-fourth") - -; character test - -(test '("~c" #\a) "a") -(test '("~@c" #\a) "#\\a") -(test `("~@c" ,(integer->char 32)) "#\\space") -(test `("~@c" ,(integer->char 0)) "#\\nul") -(test `("~@c" ,(integer->char 27)) "#\\esc") -(test `("~@c" ,(integer->char 127)) "#\\del") -(test `("~@c" ,(integer->char 128)) "#\\200") -(test `("~@c" ,(integer->char 255)) "#\\377") -(test '("~65c") "A") -(test '("~7@c") "#\\bel") -(test '("~:c" #\a) "a") -(test `("~:c" ,(integer->char 1)) "^A") -(test `("~:c" ,(integer->char 27)) "^[") -(test '("~7:c") "^G") -(test `("~:c" ,(integer->char 128)) "#\\200") -(test `("~:c" ,(integer->char 127)) "#\\177") -(test `("~:c" ,(integer->char 255)) "#\\377") - - -; plural test - -(test '("test~p" 1) "test") -(test '("test~p" 2) "tests") -(test '("test~p" 0) "tests") -(test '("tr~@p" 1) "try") -(test '("tr~@p" 2) "tries") -(test '("tr~@p" 0) "tries") -(test '("~a test~:p" 10) "10 tests") -(test '("~a test~:p" 1) "1 test") - -; tilde test - -(test '("~~~~") "~~") -(test '("~3~") "~~~") - -; whitespace character test - -(test '("~%") " -") -(test '("~3%") " - - -") -(test '("~&") "") -(test '("abc~&") "abc -") -(test '("abc~&def") "abc -def") -(test '("~&") " -") -(test '("~3&") " - -") -(test '("abc~3&") "abc - - -") -(test '("~|") (string slib:form-feed)) -(test '("~_~_~_") " ") -(test '("~3_") " ") -(test '("~/") (string slib:tab)) -(test '("~3/") (make-string 3 slib:tab)) - -; tabulate test - -(test '("~0&~3t") " ") -(test '("~0&~10t") " ") -(test '("~10t") "") -(test '("~0&1234567890~,8tABC") "1234567890 ABC") -(test '("~0&1234567890~0,8tABC") "1234567890 ABC") -(test '("~0&1234567890~1,8tABC") "1234567890 ABC") -(test '("~0&1234567890~2,8tABC") "1234567890ABC") -(test '("~0&1234567890~3,8tABC") "1234567890 ABC") -(test '("~0&1234567890~4,8tABC") "1234567890 ABC") -(test '("~0&1234567890~5,8tABC") "1234567890 ABC") -(test '("~0&1234567890~6,8tABC") "1234567890 ABC") -(test '("~0&1234567890~7,8tABC") "1234567890 ABC") -(test '("~0&1234567890~8,8tABC") "1234567890 ABC") -(test '("~0&1234567890~9,8tABC") "1234567890 ABC") -(test '("~0&1234567890~10,8tABC") "1234567890ABC") -(test '("~0&1234567890~11,8tABC") "1234567890 ABC") -(test '("~0&12345~,8tABCDE~,8tXYZ") "12345 ABCDE XYZ") -(test '("~,8t+++~,8t===") " +++ ===") -(test '("~0&ABC~,8,'.tDEF") "ABC......DEF") -(test '("~0&~3,8@tABC") " ABC") -(test '("~0&1234~3,8@tABC") "1234 ABC") -(test '("~0&12~3,8@tABC~3,8@tDEF") "12 ABC DEF") - -; indirection test - -(test '("~a ~? ~a" 10 "~a ~a" (20 30) 40) "10 20 30 40") -(test '("~a ~@? ~a" 10 "~a ~a" 20 30 40) "10 20 30 40") - -; field test - -(test '("~10a" "abc") "abc ") -(test '("~10@a" "abc") " abc") -(test '("~10a" "0123456789abc") "0123456789abc") -(test '("~10@a" "0123456789abc") "0123456789abc") - -; pad character test - -(test '("~10,,,'*a" "abc") "abc*******") -(test '("~10,,,'Xa" "abc") "abcXXXXXXX") -(test '("~10,,,42a" "abc") "abc*******") -(test '("~10,,,'*@a" "abc") "*******abc") -(test '("~10,,3,'*a" "abc") "abc*******") -(test '("~10,,3,'*a" "0123456789abc") "0123456789abc***") ; min. padchar length -(test '("~10,,3,'*@a" "0123456789abc") "***0123456789abc") - -; colinc, minpad padding test - -(test '("~10,8,0,'*a" 123) "123********") -(test '("~10,9,0,'*a" 123) "123*********") -(test '("~10,10,0,'*a" 123) "123**********") -(test '("~10,11,0,'*a" 123) "123***********") -(test '("~8,1,0,'*a" 123) "123*****") -(test '("~8,2,0,'*a" 123) "123******") -(test '("~8,3,0,'*a" 123) "123******") -(test '("~8,4,0,'*a" 123) "123********") -(test '("~8,5,0,'*a" 123) "123*****") -(test '("~8,1,3,'*a" 123) "123*****") -(test '("~8,1,5,'*a" 123) "123*****") -(test '("~8,1,6,'*a" 123) "123******") -(test '("~8,1,9,'*a" 123) "123*********") - -; slashify test - -(test '("~s" "abc") "\"abc\"") -(test '("~s" "abc \\ abc") "\"abc \\\\ abc\"") -(test '("~a" "abc \\ abc") "abc \\ abc") -(test '("~s" "abc \" abc") "\"abc \\\" abc\"") -(test '("~a" "abc \" abc") "abc \" abc") -(test '("~s" #\space) "#\\space") -(test '("~s" #\newline) "#\\newline") -(test `("~s" ,slib:tab) "#\\ht") -(test '("~s" #\a) "#\\a") -(test '("~a" (a "b" c)) "(a \"b\" c)") - -; symbol case force test - -(define format:old-scc format:symbol-case-conv) -(set! format:symbol-case-conv string-upcase) -(test '("~a" abc) "ABC") -(set! format:symbol-case-conv string-downcase) -(test '("~s" abc) "abc") -(set! format:symbol-case-conv string-capitalize) -(test '("~s" abc) "Abc") -(set! format:symbol-case-conv format:old-scc) - -; read proof test - -(test `("~:s" ,display) - (begin - (set! format:read-proof #t) - (format:iobj->str display))) -(test `("~:a" ,display) - (begin - (set! format:read-proof #t) - (format:iobj->str display))) -(test `("~:a" (1 2 ,display)) - (begin - (set! format:read-proof #t) - (string-append "(1 2 " (format:iobj->str display) ")"))) -(test '("~:a" "abc") "abc") -(set! format:read-proof #f) - -; internal object case type force test - -(set! format:iobj-case-conv string-upcase) -(test `("~a" ,display) (string-upcase (format:iobj->str display))) -(set! format:iobj-case-conv string-downcase) -(test `("~s" ,display) (string-downcase (format:iobj->str display))) -(set! format:iobj-case-conv string-capitalize) -(test `("~s" ,display) (string-capitalize (format:iobj->str display))) -(set! format:iobj-case-conv #f) - -; continuation line test - -(test '("abc~ - 123") "abc123") -(test '("abc~ -123") "abc123") -(test '("abc~ -") "abc") -(test '("abc~: - def") "abc def") -(test '("abc~@ - def") -"abc -def") - -; flush output (can't test it here really) - -(test '("abc ~! xyz") "abc xyz") - -; string case conversion - -(test '("~a ~(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc hello world xyz") -(test '("~a ~:(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello World xyz") -(test '("~a ~@(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello world xyz") -(test '("~a ~:@(~a~) ~a" "abc" "hello world" "xyz") "abc HELLO WORLD xyz") -(test '("~:@(~a~)" (a b c)) "(A B C)") -(test '("~:@(~x~)" 255) "FF") -(test '("~:@(~p~)" 2) "S") -(test `("~:@(~a~)" ,display) (string-upcase (format:iobj->str display))) -(test '("~:(~a ~a ~a~) ~a" "abc" "xyz" "123" "world") "Abc Xyz 123 world") - -; variable parameter - -(test '("~va" 10 "abc") "abc ") -(test '("~v,,,va" 10 42 "abc") "abc*******") - -; number of remaining arguments as parameter - -(test '("~#,,,'*@a ~a ~a ~a" 1 1 1 1) "***1 1 1 1") - -; argument jumping - -(test '("~a ~* ~a" 10 20 30) "10 30") -(test '("~a ~2* ~a" 10 20 30 40) "10 40") -(test '("~a ~:* ~a" 10) "10 10") -(test '("~a ~a ~2:* ~a ~a" 10 20) "10 20 10 20") -(test '("~a ~a ~@* ~a ~a" 10 20) "10 20 10 20") -(test '("~a ~a ~4@* ~a ~a" 10 20 30 40 50 60) "10 20 50 60") - -; conditionals - -(test '("~[abc~;xyz~]" 0) "abc") -(test '("~[abc~;xyz~]" 1) "xyz") -(test '("~[abc~;xyz~:;456~]" 99) "456") -(test '("~0[abc~;xyz~:;456~]") "abc") -(test '("~1[abc~;xyz~:;456~] ~a" 100) "xyz 100") -(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]") "no arg") -(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10) "10") -(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20) "10 and 20") -(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20 30) "10, 20 and 30") -(test '("~:[hello~;world~] ~a" #t 10) "world 10") -(test '("~:[hello~;world~] ~a" #f 10) "hello 10") -(test '("~@[~a tests~]" #f) "") -(test '("~@[~a tests~]" 10) "10 tests") -(test '("~@[~a test~:p~] ~a" 10 done) "10 tests done") -(test '("~@[~a test~:p~] ~a" 1 done) "1 test done") -(test '("~@[~a test~:p~] ~a" 0 done) "0 tests done") -(test '("~@[~a test~:p~] ~a" #f done) " done") -(test '("~@[ level = ~d~]~@[ length = ~d~]" #f 5) " length = 5") -(test '("~[abc~;~[4~;5~;6~]~;xyz~]" 0) "abc") ; nested conditionals (irrghh) -(test '("~[abc~;~[4~;5~;6~]~;xyz~]" 2) "xyz") -(test '("~[abc~;~[4~;5~;6~]~;xyz~]" 1 2) "6") - -; iteration - -(test '("~{ ~a ~}" (a b c)) " a b c ") -(test '("~{ ~a ~}" ()) "") -(test '("~{ ~a ~5,,,'*a~}" (a b c d)) " a b**** c d****") -(test '("~{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1 b,2 c,3 ") -(test '("~2{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1 b,2 ") -(test '("~3{~a ~} ~a" (a b c d e) 100) "a b c 100") -(test '("~0{~a ~} ~a" (a b c d e) 100) " 100") -(test '("~:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b c,d g,h ") -(test '("~2:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b c,d ") -(test '("~@{ ~a,~a ~}" a 1 b 2 c 3) " a,1 b,2 c,3 ") -(test '("~2@{ ~a,~a ~} <~a|~a>" a 1 b 2 c 3) " a,1 b,2 ") -(test '("~:@{ ~a,~a ~}" (a 1) (b 2) (c 3)) " a,1 b,2 c,3 ") -(test '("~2:@{ ~a,~a ~} ~a" (a 1) (b 2) (c 3)) " a,1 b,2 (c 3)") -(test '("~{~}" "<~a,~a>" (a 1 b 2 c 3)) "") -(test '("~{ ~a ~{<~a>~}~} ~a" (a (1 2) b (3 4)) 10) " a <1><2> b <3><4> 10") - -; up and out - -(test '("abc ~^ xyz") "abc ") -(test '("~@(abc ~^ xyz~) ~a" 10) "ABC xyz 10") -(test '("done. ~^ ~d warning~:p. ~^ ~d error~:p.") "done. ") -(test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10) "done. 10 warnings. ") -(test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10 1) - "done. 10 warnings. 1 error.") -(test '("~{ ~a ~^<~a>~} ~a" (a b c d e f) 10) " a c e 10") -(test '("~{ ~a ~^<~a>~} ~a" (a b c d e) 10) " a c e 10") -(test '("abc~0^ xyz") "abc") -(test '("abc~9^ xyz") "abc xyz") -(test '("abc~7,4^ xyz") "abc xyz") -(test '("abc~7,7^ xyz") "abc") -(test '("abc~3,7,9^ xyz") "abc") -(test '("abc~8,7,9^ xyz") "abc xyz") -(test '("abc~3,7,5^ xyz") "abc xyz") - -; complexity tests (oh my god, I hardly understand them myself (see CL std)) - -(define fmt "Items:~#[ none~; ~a~; ~a and ~a~:;~@{~#[~; and~] ~a~^,~}~].") - -(test `(,fmt ) "Items: none.") -(test `(,fmt foo) "Items: foo.") -(test `(,fmt foo bar) "Items: foo and bar.") -(test `(,fmt foo bar baz) "Items: foo, bar, and baz.") -(test `(,fmt foo bar baz zok) "Items: foo, bar, baz, and zok.") - -; fixed floating points - -(cond - (format:floats - (test '("~6,2f" 3.14159) " 3.14") - (test '("~6,1f" 3.14159) " 3.1") - (test '("~6,0f" 3.14159) " 3.") - (test '("~5,1f" 0) " 0.0") - (test '("~10,7f" 3.14159) " 3.1415900") - (test '("~10,7f" -3.14159) "-3.1415900") - (test '("~10,7@f" 3.14159) "+3.1415900") - (test '("~6,3f" 0.0) " 0.000") - (test '("~6,4f" 0.007) "0.0070") - (test '("~6,3f" 0.007) " 0.007") - (test '("~6,2f" 0.007) " 0.01") - (test '("~3,2f" 0.007) ".01") - (test '("~3,2f" -0.007) "-.01") - (test '("~6,2,,,'*f" 3.14159) "**3.14") - (test '("~6,3,,'?f" 12345.56789) "??????") - (test '("~6,3f" 12345.6789) "12345.679") - (test '("~,3f" 12345.6789) "12345.679") - (test '("~,3f" 9.9999) "10.000") - (test '("~6f" 23.4) " 23.4") - (test '("~6f" 1234.5) "1234.5") - (test '("~6f" 12345678) "12345678.0") - (test '("~6,,,'?f" 12345678) "??????") - (test '("~6f" 123.56789) "123.57") - (test '("~6f" 123.0) " 123.0") - (test '("~6f" -123.0) "-123.0") - (test '("~6f" 0.0) " 0.0") - (test '("~3f" 3.141) "3.1") - (test '("~2f" 3.141) "3.") - (test '("~1f" 3.141) "3.141") - (test '("~f" 123.56789) "123.56789") - (test '("~f" -314.0) "-314.0") - (test '("~f" 1e4) "10000.0") - (test '("~f" -1.23e10) "-12300000000.0") - (test '("~f" 1e-4) "0.0001") - (test '("~f" -1.23e-10) "-0.000000000123") - (test '("~@f" 314.0) "+314.0") - (test '("~,,3f" 0.123456) "123.456") - (test '("~,,-3f" -123.456) "-0.123456") - (test '("~5,,3f" 0.123456) "123.5") -)) - -; exponent floating points - -(cond - (format:floats - (test '("~e" 3.14159) "3.14159E+0") - (test '("~e" 0.00001234) "1.234E-5") - (test '("~,,,0e" 0.00001234) "0.1234E-4") - (test '("~,3e" 3.14159) "3.142E+0") - (test '("~,3@e" 3.14159) "+3.142E+0") - (test '("~,3@e" 0.0) "+0.000E+0") - (test '("~,0e" 3.141) "3.E+0") - (test '("~,3,,0e" 3.14159) "0.314E+1") - (test '("~,5,3,-2e" 3.14159) "0.00314E+003") - (test '("~,5,3,-5e" -3.14159) "-0.00000E+006") - (test '("~,5,2,2e" 3.14159) "31.4159E-01") - (test '("~,5,2,,,,'ee" 0.0) "0.00000e+00") - (test '("~12,3e" -3.141) " -3.141E+0") - (test '("~12,3,,,,'#e" -3.141) "###-3.141E+0") - (test '("~10,2e" -1.236e-4) " -1.24E-4") - (test '("~5,3e" -3.141) "-3.141E+0") - (test '("~5,3,,,'*e" -3.141) "*****") - (test '("~3e" 3.14159) "3.14159E+0") - (test '("~4e" 3.14159) "3.14159E+0") - (test '("~5e" 3.14159) "3.E+0") - (test '("~5,,,,'*e" 3.14159) "3.E+0") - (test '("~6e" 3.14159) "3.1E+0") - (test '("~7e" 3.14159) "3.14E+0") - (test '("~7e" -3.14159) "-3.1E+0") - (test '("~8e" 3.14159) "3.142E+0") - (test '("~9e" 3.14159) "3.1416E+0") - (test '("~9,,,,,,'ee" 3.14159) "3.1416e+0") - (test '("~10e" 3.14159) "3.14159E+0") - (test '("~11e" 3.14159) " 3.14159E+0") - (test '("~12e" 3.14159) " 3.14159E+0") - (test '("~13,6,2,-5e" 3.14159) " 0.000003E+06") - (test '("~13,6,2,-4e" 3.14159) " 0.000031E+05") - (test '("~13,6,2,-3e" 3.14159) " 0.000314E+04") - (test '("~13,6,2,-2e" 3.14159) " 0.003142E+03") - (test '("~13,6,2,-1e" 3.14159) " 0.031416E+02") - (test '("~13,6,2,0e" 3.14159) " 0.314159E+01") - (test '("~13,6,2,1e" 3.14159) " 3.141590E+00") - (test '("~13,6,2,2e" 3.14159) " 31.41590E-01") - (test '("~13,6,2,3e" 3.14159) " 314.1590E-02") - (test '("~13,6,2,4e" 3.14159) " 3141.590E-03") - (test '("~13,6,2,5e" 3.14159) " 31415.90E-04") - (test '("~13,6,2,6e" 3.14159) " 314159.0E-05") - (test '("~13,6,2,7e" 3.14159) " 3141590.E-06") - (test '("~13,6,2,8e" 3.14159) "31415900.E-07") - (test '("~7,3,,-2e" 0.001) ".001E+0") - (test '("~8,3,,-2@e" 0.001) "+.001E+0") - (test '("~8,3,,-2@e" -0.001) "-.001E+0") - (test '("~8,3,,-2e" 0.001) "0.001E+0") - (test '("~7,,,-2e" 0.001) "0.00E+0") - (test '("~12,3,1e" 3.14159e12) " 3.142E+12") - (test '("~12,3,1,,'*e" 3.14159e12) "************") - (test '("~5,3,1e" 3.14159e12) "3.142E+12") -)) - -; general floating point (this test is from Steele's CL book) - -(cond - (format:floats - (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" - 0.0314159 0.0314159 0.0314159 0.0314159) - " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2") - (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" - 0.314159 0.314159 0.314159 0.314159) - " 0.31 |0.314 |0.314 | 0.31 ") - (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" - 3.14159 3.14159 3.14159 3.14159) - " 3.1 | 3.14 | 3.14 | 3.1 ") - (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" - 31.4159 31.4159 31.4159 31.4159) - " 31. | 31.4 | 31.4 | 31. ") - (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" - 314.159 314.159 314.159 314.159) - " 3.14E+2| 314. | 314. | 3.14E+2") - (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" - 3141.59 3141.59 3141.59 3141.59) - " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3") - (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" - 3.14E12 3.14E12 3.14E12 3.14E12) - "*********|314.0$+10|0.314E+13| 3.14E+12") - (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" - 3.14E120 3.14E120 3.14E120 3.14E120) - "*********|?????????|%%%%%%%%%|3.14E+120") - - (test '("~g" 0.0) "0.0 ") ; further ~g tests - (test '("~g" 0.1) "0.1 ") - (test '("~g" 0.01) "1.0E-2") - (test '("~g" 123.456) "123.456 ") - (test '("~g" 123456.7) "123456.7 ") - (test '("~g" 123456.78) "123456.78 ") - (test '("~g" 0.9282) "0.9282 ") - (test '("~g" 0.09282) "9.282E-2") - (test '("~g" 1) "1.0 ") - (test '("~g" 12) "12.0 ") - )) - -; dollar floating point - -(cond - (format:floats - (test '("~$" 1.23) "1.23") - (test '("~$" 1.2) "1.20") - (test '("~$" 0.0) "0.00") - (test '("~$" 9.999) "10.00") - (test '("~3$" 9.9999) "10.000") - (test '("~,4$" 3.2) "0003.20") - (test '("~,4$" 10000.2) "10000.20") - (test '("~,4,10$" 3.2) " 0003.20") - (test '("~,4,10@$" 3.2) " +0003.20") - (test '("~,4,10:@$" 3.2) "+ 0003.20") - (test '("~,4,10:$" -3.2) "- 0003.20") - (test '("~,4,10$" -3.2) " -0003.20") - (test '("~,,10@$" 3.2) " +3.20") - (test '("~,,10:@$" 3.2) "+ 3.20") - (test '("~,,10:@$" -3.2) "- 3.20") - (test '("~,,10,'_@$" 3.2) "_____+3.20") - (test '("~,,4$" 1234.4) "1234.40") -)) - -; complex numbers - -(cond - (format:complex-numbers - (test '("~i" 3.0) "3.0+0.0i") - (test '("~,3i" 3.0) "3.000+0.000i") - (test `("~7,2i" ,(string->number "3.0+5.0i")) " 3.00 +5.00i") - (test `("~7,2,1i" ,(string->number "3.0+5.0i")) " 30.00 +50.00i") - (test `("~7,2@i" ,(string->number "3.0+5.0i")) " +3.00 +5.00i") - (test `("~7,2,,,'*@i" ,(string->number "3.0+5.0i")) "**+3.00**+5.00i") - )) ; note: some parsers choke syntactically on reading a complex - ; number though format:complex is #f; this is why we put them in - ; strings - -; inquiry test - -(test '("~:q") format:version) - -(if (not test-verbose) (display "done.")) - -(format #t "~%~a Test~:p completed. (~a failure~:p)~2%" total fails) - -; eof diff --git a/module/slib/gambit.init b/module/slib/gambit.init deleted file mode 100644 index 6d4976fc5..000000000 --- a/module/slib/gambit.init +++ /dev/null @@ -1,301 +0,0 @@ -;;;"gambit.init" Initialization for SLIB for Gambit -*-scheme-*- -;;; Author: Aubrey Jaffer -;;; -;;; This code is in the public domain. - -;;; Updated 1992 February 1 for Gambit v1.71 -- by Ken Dickey -;;; Date: Wed, 12 Jan 1994 15:03:12 -0500 -;;; From: barnett@armadillo.urich.edu (Lewis Barnett) -;;; Relative pathnames for Slib in MacGambit -;;; Hacked yet again for Gambit v2.4, Jan 1997, by Mike Pope - -(define (software-type) 'MACOS) ; for MacGambit. -(define (software-type) 'UNIX) ; for Unix platforms. - -(define (scheme-implementation-type) 'gambit) - -;;; (scheme-implementation-home-page) should return a (string) URI -;;; (Uniform Resource Identifier) for this scheme implementation's home -;;; page; or false if there isn't one. - -(define (scheme-implementation-home-page) - "http://www.iro.umontreal.ca/~gambit/index.html") - -(define (scheme-implementation-version) "3.0") -;;; Jefferson R. Lowrey reports that in Gambit Version 3.0 -;;; (argv) returns '(""). -(define argv - (if (equal? '("") (argv)) ;Fix only if it is broken. - (lambda () '("Lowrey HD:Development:MacGambit 3.0:Interpreter")) - argv)) - -;;; (implementation-vicinity) should be defined to be the pathname of -;;; the directory where any auxillary files to your Scheme -;;; implementation reside. - -(define implementation-vicinity - (case (software-type) - ((UNIX) (lambda () "/usr/local/src/scheme/")) - ((VMS) (lambda () "scheme$src:")) - ((MS-DOS) (lambda () "C:\\scheme\\")) - ((WINDOWS) (lambda () "c:/scheme/")) - ((MACOS) - (let ((arg0 (list-ref (argv) 0))) - (let loop ((i (- (string-length arg0) 1))) - (cond ((negative? i) "") - ((char=? #\: (string-ref arg0 i)) - (set! arg0 (substring arg0 0 (+ i 1))) - (lambda () arg0)) - (else (loop (- i 1))))))))) - -;;; (library-vicinity) should be defined to be the pathname of the -;;; directory where files of Scheme library functions reside. - -;;; This assumes that the slib files are in a folder -;;; called slib in the same directory as the MacGambit Interpreter. - -(define library-vicinity - (let ((library-path - (case (software-type) - ((UNIX) "/usr/local/lib/slib/") - ((MACOS) (string-append (implementation-vicinity) "slib:")) - ((AMIGA) "dh0:scm/Library/") - ((VMS) "lib$scheme:") - ((WINDOWS MS-DOS) "C:\\SLIB\\") - (else "")))) - (lambda () library-path))) - -;;; (home-vicinity) should return the vicinity of the user's HOME -;;; directory, the directory which typically contains files which -;;; customize a computer environment for a user. - -(define (home-vicinity) #f) - -;;; *FEATURES* should be set to a list of symbols describing features -;;; of this implementation. Suggestions for features are: - -(define *features* - '( - source ;can load scheme source files - ;(slib:load-source "filename") - compiled ;can load compiled files - ;(slib:load-compiled "filename") - rev4-report ;conforms to -; rev3-report ;conforms to - ieee-p1178 ;conforms to - sicp ;runs code from Structure and - ;Interpretation of Computer - ;Programs by Abelson and Sussman. - rev4-optional-procedures ;LIST-TAIL, STRING->LIST, - ;LIST->STRING, STRING-COPY, - ;STRING-FILL!, LIST->VECTOR, - ;VECTOR->LIST, and VECTOR-FILL! -; rev2-procedures ;SUBSTRING-MOVE-LEFT!, - ;SUBSTRING-MOVE-RIGHT!, - ;SUBSTRING-FILL!, - ;STRING-NULL?, APPEND!, 1+, - ;-1+, ?, >=? - multiarg/and- ;/ and - can take more than 2 args. - multiarg-apply ;APPLY can take more than 2 args. - rationalize - delay ;has DELAY and FORCE - with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE - string-port ;has CALL-WITH-INPUT-STRING and - ;CALL-WITH-OUTPUT-STRING - transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF - char-ready? -; macro ;has R4RS high level macros - defmacro ;has Common Lisp DEFMACRO -; record ;has user defined data structures -; values ;proposed multiple values -; dynamic-wind ;proposed dynamic-wind - ieee-floating-point ;conforms to - full-continuation ;can return multiple times -; object-hash ;has OBJECT-HASH - -; sort -; queue ;queues - pretty-print -; object->string -; format - trace ;has macros: TRACE and UNTRACE -; compiler ;has (COMPILER) -; ed ;(ED) is editor - system ;posix (system ) -; 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 - )) - -;;; (OUTPUT-PORT-WIDTH ) -(define (output-port-width . arg) 79) - -;;; (OUTPUT-PORT-HEIGHT ) -(define (output-port-height . arg) 24) - -;;; (CURRENT-ERROR-PORT) -(define current-error-port - (let ((port (current-output-port))) - (lambda () port))) - -;;; (TMPNAM) makes a temporary file name. -(define tmpnam (let ((cntr 100)) - (lambda () (set! cntr (+ 1 cntr)) - (string-append "slib_" (number->string cntr))))) - -;;; Gambit supports SYSTEM as an "Unstable Addition"; Watch for changes. -(define system ##shell-command) - -;;; (FILE-EXISTS? ) -;(define (file-exists? f) #f) - -;;; (DELETE-FILE ) -(define (delete-file f) #f) - -;;; FORCE-OUTPUT flushes any pending output on optional arg output port -;;; use this definition if your system doesn't have such a procedure. -(define force-output flush-output) - -;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string -;;; port versions of CALL-WITH-*PUT-FILE. - -;;; "rationalize" adjunct procedures. -(define (find-ratio x e) - (let ((rat (rationalize x e))) - (list (numerator rat) (denominator rat)))) -(define (find-ratio-between x y) - (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) - -;;; CHAR-CODE-LIMIT is one greater than the largest integer which can -;;; be returned by CHAR->INTEGER. -(define char-code-limit 256) - -;; MOST-POSITIVE-FIXNUM is used in modular.scm -(define most-positive-fixnum #x1FFFFFFF) ; 3-bit tag for 68K - -;;; Return argument -(define (identity x) x) - -;;; SLIB:EVAL is single argument eval using the top-level (user) environment. -(define slib:eval eval) - -; Define program-arguments as argv -(define program-arguments argv) - -;;; If your implementation provides R4RS macros: -;(define macro:eval slib:eval) -;(define macro:load load) - -; Set up defmacro in terms of gambit's define-macro -(define-macro (defmacro name args . body) - `(define-macro (,name ,@args) ,@body)) - -(define *defmacros* - (list (cons 'defmacro - (lambda (name parms . body) - `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) - *defmacros*)))))) -(define (defmacro? m) (and (assq m *defmacros*) #t)) - -(define (macroexpand-1 e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) (set! a (assq a *defmacros*)) - (if a (apply (cdr a) (cdr e)) e)) - (else e))) - e)) - -(define (macroexpand e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) - (set! a (assq a *defmacros*)) - (if a (macroexpand (apply (cdr a) (cdr e))) e)) - (else e))) - e)) - -(define gentemp - (let ((*gensym-counter* -1)) - (lambda () - (set! *gensym-counter* (+ *gensym-counter* 1)) - (string->symbol - (string-append "slib:G" (number->string *gensym-counter*)))))) - -(define base:eval slib:eval) -(define defmacro:eval base:eval) - -(define (defmacro:load ) - (slib:eval-load defmacro:eval)) - -(define (slib:eval-load evl) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (call-with-input-file - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* ) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - -(define slib:warn - (lambda args - (let ((cep (current-error-port))) - (if (provided? 'trace) (print-call-stack cep)) - (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) - -;; define an error procedure for the library -(define (slib:error . args) - (if (provided? 'trace) (print-call-stack (current-error-port))) - (apply error args)) - -;; define these as appropriate for your system. -(define slib:tab (integer->char 9)) -(define slib:form-feed (integer->char 12)) - -;;; Support for older versions of Scheme. Not enough code for its own file. -(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) -(define t #t) -(define nil #f) - -;;; Define these if your implementation's syntax can support it and if -;;; they are not already defined. - -(define (1+ n) (+ n 1)) -(define (-1+ n) (- n 1)) -(define 1- -1+) - -(define in-vicinity string-append) - -;;; Define SLIB:EXIT to be the implementation procedure to exit or -;;; return if exitting not supported. -(define slib:exit (lambda args (exit))) - -;;; Here for backward compatability -(define scheme-file-suffix - (let ((suffix (case (software-type) - ((NOSVE) "_scm") - (else ".scm")))) - (lambda () suffix))) - -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever -;;; suffix all the module files in SLIB have. See feature 'SOURCE. - -(define slib:load-source load) - -;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced -;;; by compiling "foo.scm" if this implementation can compile files. -;;; See feature 'COMPILED. - -(define slib:load-compiled load) - -;;; At this point SLIB:LOAD must be able to load SLIB files. - -(define slib:load slib:load-source) - -(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/module/slib/genwrite.scm b/module/slib/genwrite.scm deleted file mode 100644 index 2e4bf6060..000000000 --- a/module/slib/genwrite.scm +++ /dev/null @@ -1,266 +0,0 @@ -;;"genwrite.scm" generic write used by pretty-print and truncated-print. -;; Copyright (c) 1991, Marc Feeley -;; Author: Marc Feeley (feeley@iro.umontreal.ca) -;; Distribution restrictions: none - -(define genwrite:newline-str (make-string 1 #\newline)) - -(define (generic-write obj display? width output) - - (define (read-macro? l) - (define (length1? l) (and (pair? l) (null? (cdr l)))) - (let ((head (car l)) (tail (cdr l))) - (case head - ((quote quasiquote unquote unquote-splicing) (length1? tail)) - (else #f)))) - - (define (read-macro-body l) - (cadr l)) - - (define (read-macro-prefix l) - (let ((head (car l)) (tail (cdr l))) - (case head - ((quote) "'") - ((quasiquote) "`") - ((unquote) ",") - ((unquote-splicing) ",@")))) - - (define (out str col) - (and col (output str) (+ col (string-length str)))) - - (define (wr obj col) - - (define (wr-expr expr col) - (if (read-macro? expr) - (wr (read-macro-body expr) (out (read-macro-prefix expr) col)) - (wr-lst expr col))) - - (define (wr-lst l col) - (if (pair? l) - (let loop ((l (cdr l)) - (col (and col (wr (car l) (out "(" col))))) - (cond ((not col) col) - ((pair? l) - (loop (cdr l) (wr (car l) (out " " col)))) - ((null? l) (out ")" col)) - (else (out ")" (wr l (out " . " col)))))) - (out "()" col))) - - (cond ((pair? obj) (wr-expr obj col)) - ((null? obj) (wr-lst obj col)) - ((vector? obj) (wr-lst (vector->list obj) (out "#" col))) - ((boolean? obj) (out (if obj "#t" "#f") col)) - ((number? obj) (out (number->string obj) col)) - ((symbol? obj) (out (symbol->string obj) col)) - ((procedure? obj) (out "#[procedure]" col)) - ((string? obj) (if display? - (out obj col) - (let loop ((i 0) (j 0) (col (out "\"" col))) - (if (and col (< j (string-length obj))) - (let ((c (string-ref obj j))) - (if (or (char=? c #\\) - (char=? c #\")) - (loop j - (+ j 1) - (out "\\" - (out (substring obj i j) - col))) - (loop i (+ j 1) col))) - (out "\"" - (out (substring obj i j) col)))))) - ((char? obj) (if display? - (out (make-string 1 obj) col) - (out (case obj - ((#\space) "space") - ((#\newline) "newline") - (else (make-string 1 obj))) - (out "#\\" col)))) - ((input-port? obj) (out "#[input-port]" col)) - ((output-port? obj) (out "#[output-port]" col)) - ((eof-object? obj) (out "#[eof-object]" col)) - (else (out "#[unknown]" col)))) - - (define (pp obj col) - - (define (spaces n col) - (if (> n 0) - (if (> n 7) - (spaces (- n 8) (out " " col)) - (out (substring " " 0 n) col)) - col)) - - (define (indent to col) - (and col - (if (< to col) - (and (out genwrite:newline-str col) (spaces to 0)) - (spaces (- to col) col)))) - - (define (pr obj col extra pp-pair) - (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines - (let ((result '()) - (left (min (+ (- (- width col) extra) 1) max-expr-width))) - (generic-write obj display? #f - (lambda (str) - (set! result (cons str result)) - (set! left (- left (string-length str))) - (> left 0))) - (if (> left 0) ; all can be printed on one line - (out (reverse-string-append result) col) - (if (pair? obj) - (pp-pair obj col extra) - (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) - (wr obj col))) - - (define (pp-expr expr col extra) - (if (read-macro? expr) - (pr (read-macro-body expr) - (out (read-macro-prefix expr) col) - extra - pp-expr) - (let ((head (car expr))) - (if (symbol? head) - (let ((proc (style head))) - (if proc - (proc expr col extra) - (if (> (string-length (symbol->string head)) - max-call-head-width) - (pp-general expr col extra #f #f #f pp-expr) - (pp-call expr col extra pp-expr)))) - (pp-list expr col extra pp-expr))))) - - ; (head item1 - ; item2 - ; item3) - (define (pp-call expr col extra pp-item) - (let ((col* (wr (car expr) (out "(" col)))) - (and col - (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) - - ; (item1 - ; item2 - ; item3) - (define (pp-list l col extra pp-item) - (let ((col (out "(" col))) - (pp-down l col col extra pp-item))) - - (define (pp-down l col1 col2 extra pp-item) - (let loop ((l l) (col col1)) - (and col - (cond ((pair? l) - (let ((rest (cdr l))) - (let ((extra (if (null? rest) (+ extra 1) 0))) - (loop rest - (pr (car l) (indent col2 col) extra pp-item))))) - ((null? l) - (out ")" col)) - (else - (out ")" - (pr l - (indent col2 (out "." (indent col2 col))) - (+ extra 1) - pp-item))))))) - - (define (pp-general expr col extra named? pp-1 pp-2 pp-3) - - (define (tail1 rest col1 col2 col3) - (if (and pp-1 (pair? rest)) - (let* ((val1 (car rest)) - (rest (cdr rest)) - (extra (if (null? rest) (+ extra 1) 0))) - (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) - (tail2 rest col1 col2 col3))) - - (define (tail2 rest col1 col2 col3) - (if (and pp-2 (pair? rest)) - (let* ((val1 (car rest)) - (rest (cdr rest)) - (extra (if (null? rest) (+ extra 1) 0))) - (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) - (tail3 rest col1 col2))) - - (define (tail3 rest col1 col2) - (pp-down rest col2 col1 extra pp-3)) - - (let* ((head (car expr)) - (rest (cdr expr)) - (col* (wr head (out "(" col)))) - (if (and named? (pair? rest)) - (let* ((name (car rest)) - (rest (cdr rest)) - (col** (wr name (out " " col*)))) - (tail1 rest (+ col indent-general) col** (+ col** 1))) - (tail1 rest (+ col indent-general) col* (+ col* 1))))) - - (define (pp-expr-list l col extra) - (pp-list l col extra pp-expr)) - - (define (pp-LAMBDA expr col extra) - (pp-general expr col extra #f pp-expr-list #f pp-expr)) - - (define (pp-IF expr col extra) - (pp-general expr col extra #f pp-expr #f pp-expr)) - - (define (pp-COND expr col extra) - (pp-call expr col extra pp-expr-list)) - - (define (pp-CASE expr col extra) - (pp-general expr col extra #f pp-expr #f pp-expr-list)) - - (define (pp-AND expr col extra) - (pp-call expr col extra pp-expr)) - - (define (pp-LET expr col extra) - (let* ((rest (cdr expr)) - (named? (and (pair? rest) (symbol? (car rest))))) - (pp-general expr col extra named? pp-expr-list #f pp-expr))) - - (define (pp-BEGIN expr col extra) - (pp-general expr col extra #f #f #f pp-expr)) - - (define (pp-DO expr col extra) - (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr)) - - ; define formatting style (change these to suit your style) - - (define indent-general 2) - - (define max-call-head-width 5) - - (define max-expr-width 50) - - (define (style head) - (case head - ((lambda let* letrec define) pp-LAMBDA) - ((if set!) pp-IF) - ((cond) pp-COND) - ((case) pp-CASE) - ((and or) pp-AND) - ((let) pp-LET) - ((begin) pp-BEGIN) - ((do) pp-DO) - (else #f))) - - (pr obj col 0 pp-expr)) - - (if width - (out genwrite:newline-str (pp obj 0)) - (wr obj 0))) - -; (reverse-string-append l) = (apply string-append (reverse l)) - -(define (reverse-string-append l) - - (define (rev-string-append l i) - (if (pair? l) - (let* ((str (car l)) - (len (string-length str)) - (result (rev-string-append (cdr l) (+ i len)))) - (let loop ((j 0) (k (- (- (string-length result) i) len))) - (if (< j len) - (begin - (string-set! result k (string-ref str j)) - (loop (+ j 1) (+ k 1))) - result))) - (make-string i))) - - (rev-string-append l 0)) diff --git a/module/slib/getopt.scm b/module/slib/getopt.scm deleted file mode 100644 index c2962dbbe..000000000 --- a/module/slib/getopt.scm +++ /dev/null @@ -1,80 +0,0 @@ -;;; "getopt.scm" POSIX command argument processing -;Copyright (C) 1993, 1994 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(define getopt:scan #f) -(define getopt:char #\-) -(define getopt:opt #f) -(define *optind* 1) -(define *optarg* 0) - -(define (getopt argc argv optstring) - (let ((opts (string->list optstring)) - (place #f) - (arg #f) - (argref (lambda () ((if (vector? argv) vector-ref list-ref) - argv *optind*)))) - (and - (cond ((and getopt:scan (not (string=? "" getopt:scan))) #t) - ((>= *optind* argc) #f) - (else - (set! arg (argref)) - (cond ((or (<= (string-length arg) 1) - (not (char=? (string-ref arg 0) getopt:char))) - #f) - ((and (= (string-length arg) 2) - (char=? (string-ref arg 1) getopt:char)) - (set! *optind* (+ *optind* 1)) - #f) - (else - (set! getopt:scan - (substring arg 1 (string-length arg))) - #t)))) - (begin - (set! getopt:opt (string-ref getopt:scan 0)) - (set! getopt:scan - (substring getopt:scan 1 (string-length getopt:scan))) - (if (string=? "" getopt:scan) (set! *optind* (+ *optind* 1))) - (set! place (member getopt:opt opts)) - (cond ((not place) #\?) - ((or (null? (cdr place)) (not (char=? #\: (cadr place)))) - getopt:opt) - ((not (string=? "" getopt:scan)) - (set! *optarg* getopt:scan) - (set! *optind* (+ *optind* 1)) - (set! getopt:scan #f) - getopt:opt) - ((< *optind* argc) - (set! *optarg* (argref)) - (set! *optind* (+ *optind* 1)) - getopt:opt) - ((and (not (null? opts)) (char=? #\: (car opts))) #\:) - (else #\?)))))) - -(define (getopt-- argc argv optstring) - (let* ((opt (getopt argc argv (string-append optstring "-:"))) - (optarg *optarg*)) - (cond ((eqv? #\- opt) ;long option - (do ((l (string-length *optarg*)) - (i 0 (+ 1 i))) - ((or (>= i l) (char=? #\= (string-ref optarg i))) - (cond - ((>= i l) (set! *optarg* #f) optarg) - (else (set! *optarg* (substring optarg (+ 1 i) l)) - (substring optarg 0 i)))))) - (else opt)))) diff --git a/module/slib/getparam.scm b/module/slib/getparam.scm deleted file mode 100644 index d5bfe1f39..000000000 --- a/module/slib/getparam.scm +++ /dev/null @@ -1,213 +0,0 @@ -;;; "getparam.scm" convert getopt to passing parameters by name. -; Copyright 1995, 1996, 1997, 2001 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'getopt) -(require 'coerce) - -(define (getopt->parameter-list argc argv optnames arities types aliases - . description) - (define (can-take-arg? opt) - (not (eq? 'boolean (list-ref arities (position opt optnames))))) - (let ((progname (list-ref argv (+ -1 *optind*))) - (optlist '()) - (long-opt-list '()) - (optstring #f) - (pos-args '()) - (parameter-list (make-parameter-list optnames)) - (curopt '*unclaimed-argument*) - (positional? (assv 0 aliases)) - (unclaimeds '())) - (define (adjoin-val val curopt) - (define ntyp (list-ref types (position curopt optnames))) - (adjoin-parameters! parameter-list - (list curopt (case ntyp - ((expression) val) - (else (coerce val ntyp)))))) - (define (finish) - (cond - (positional? - (set! unclaimeds (reverse unclaimeds)) - (do ((idx 2 (+ 1 idx)) - (alias+ (assv 1 aliases) (assv idx aliases)) - (alias- (assv -1 aliases) (assv (- idx) aliases))) - ((or (not (or alias+ alias-)) (null? unclaimeds))) - (set! unclaimeds (reverse unclaimeds)) - (cond (alias- - (set! curopt (cadr alias-)) - (adjoin-val (car unclaimeds) curopt) - (set! unclaimeds (cdr unclaimeds)))) - (set! unclaimeds (reverse unclaimeds)) - (cond ((and alias+ (not (null? unclaimeds))) - (set! curopt (cadr alias+)) - (adjoin-val (car unclaimeds) curopt) - (set! unclaimeds (cdr unclaimeds))))) - (let ((alias (assv '0 aliases))) - (cond (alias - (set! curopt (cadr alias)) - (for-each (lambda (unc) (adjoin-val unc curopt)) unclaimeds) - (set! unclaimeds '())))))) - (cond ((not (null? unclaimeds)) - (slib:warn 'getopt->parameter-list 'arguments 'unclaimed unclaimeds) - (apply parameter-list->getopt-usage - progname optnames arities types aliases description)) - (else parameter-list))) - (set! aliases - (map (lambda (alias) - (cond ((string? (car alias)) - (let ((str (string-copy (car alias)))) - (do ((i (+ -1 (string-length str)) (+ -1 i))) - ((negative? i) (cons str (cdr alias))) - (cond ((char=? #\ (string-ref str i)) - (string-set! str i #\-)))))) - ((number? (car alias)) - (set! positional? (car alias)) - alias) - (else alias))) - aliases)) - (for-each - (lambda (alias) - (define opt (car alias)) - (cond ((number? opt) (set! pos-args (cons opt pos-args))) - ((not (string? opt))) - ((< 1 (string-length opt)) - (set! long-opt-list (cons opt long-opt-list))) - ((not (= 1 (string-length opt)))) - ((can-take-arg? (cadr alias)) - (set! optlist (cons (string-ref opt 0) (cons #\: optlist)))) - (else (set! optlist (cons (string-ref opt 0) optlist))))) - aliases) - (set! optstring (list->string (cons #\: optlist))) - (let loop () - (let ((opt (getopt-- argc argv optstring))) - (case opt - ((#\: #\?) - (slib:warn 'getopt->parameter-list - (case opt - ((#\:) "argument missing after") - ((#\?) "unrecognized option")) - (string #\- getopt:opt)) - (apply parameter-list->getopt-usage - progname optnames arities types aliases description)) - ((#f) - (cond ((and (< *optind* argc) - (string=? "-" (list-ref argv *optind*))) - (set! *optind* (+ 1 *optind*)) - (finish)) - ((< *optind* argc) - (let ((topt (assoc curopt aliases))) - (if topt (set! curopt (cadr topt))) - (cond - ((and positional? (not topt)) - (set! unclaimeds - (cons (list-ref argv *optind*) unclaimeds)) - (set! *optind* (+ 1 *optind*)) (loop)) - ((and (member curopt optnames) - (adjoin-val (list-ref argv *optind*) curopt)) - (set! *optind* (+ 1 *optind*)) (loop)) - (else (slib:error 'getopt->parameter-list curopt - (list-ref argv *optind*) - 'not 'supported))))) - (else (finish)))) - (else - (cond ((char? opt) (set! opt (string opt)))) - (let ((topt (assoc opt aliases))) - (if topt (set! topt (cadr topt))) - (cond - ((not topt) - (slib:warn "Option not recognized -" opt) - (apply parameter-list->getopt-usage - progname optnames arities types aliases description)) - ((not (can-take-arg? topt)) - (adjoin-parameters! parameter-list (list topt #t)) - (loop)) - (*optarg* (set! curopt topt) (adjoin-val *optarg* curopt) (loop)) - (else -;;; (slib:warn 'getopt->parameter-list "= missing for option--" opt) - (set! curopt topt) (loop)))))))))) - -(define (parameter-list->getopt-usage comname optnames arities types aliases - . description) - (require 'printf) - (require 'common-list-functions) - (let ((aliast (map list optnames)) - (strlen=1? (lambda (s) (= 1 (string-length s)))) - (cep (current-error-port))) - (for-each (lambda (alias) - (let ((apr (assq (cadr alias) aliast))) - (set-cdr! apr (cons (car alias) (cdr apr))))) - aliases) - (fprintf cep "Usage: %s [OPTION ARGUMENT ...] ..." comname) - (do ((pos+ '()) (pos- '()) - (idx 2 (+ 1 idx)) - (alias+ (assv 1 aliases) (assv idx aliases)) - (alias- (assv -1 aliases) (assv (- idx) aliases))) - ((not (or alias+ alias-)) - (for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias))) - (reverse pos+)) - (let ((alias (assv 0 aliases))) - (if alias (fprintf cep " <%s> ..." (cadr alias)))) - (for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias))) - pos-)) - (cond (alias- (set! pos- (cons alias- pos-)))) - (cond (alias+ (set! pos+ (cons alias+ pos+))))) - (fprintf cep "\\n\\n") - (for-each - (lambda (optname arity aliat) - (let loop ((initials (remove-if-not strlen=1? (remove-if number? (cdr aliat)))) - (longname (remove-if strlen=1? (remove-if number? (cdr aliat))))) - (cond ((and (null? initials) (null? longname))) - (else (fprintf cep - (case arity - ((boolean) " %3s %s\\n") - (else " %3s %s<%s> %s\\n")) - (if (null? initials) - "" - (string-append "-" (car initials) - (if (null? longname) " " ","))) - (if (null? longname) - " " - (string-append "--" (car longname) - (case arity - ((boolean) " ") - (else "=")))) - (case arity - ((boolean) "") - (else optname)) - (case arity - ((nary nary1) "...") - (else ""))) - (loop (if (null? initials) '() (cdr initials)) - (if (null? longname) '() (cdr longname))))))) - optnames arities aliast) - (for-each (lambda (desc) (fprintf cep " %s\\n" desc)) description)) - #f) - -(define (getopt->arglist argc argv optnames positions - arities types defaulters checks aliases . description) - (define progname (list-ref argv (+ -1 *optind*))) - (let* ((params (apply getopt->parameter-list - argc argv optnames arities types aliases description)) - (fparams (and params (fill-empty-parameters defaulters params)))) - (cond ((and (list? params) - (check-parameters checks fparams) - (parameter-list->arglist positions arities fparams))) - (params (apply parameter-list->getopt-usage - progname optnames arities types aliases description)) - (else #f)))) - diff --git a/module/slib/glob.scm b/module/slib/glob.scm deleted file mode 100644 index dc396cd54..000000000 --- a/module/slib/glob.scm +++ /dev/null @@ -1,227 +0,0 @@ -;;; "glob.scm" String matching for filenames (a la BASH). -;;; Copyright (C) 1998 Radey Shouman. -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;$Header: /home/ludo/src/guile/gitification/guile-cvs/guile/guile/guile-vm/module/slib/glob.scm,v 1.1 2001/04/14 11:24:45 kei Exp $ -;;$Name: $ - -(define (glob:pattern->tokens pat) - (cond - ((string? pat) - (let loop ((i 0) - (toks '())) - (if (>= i (string-length pat)) - (reverse toks) - (let ((pch (string-ref pat i))) - (case pch - ((#\? #\*) - (loop (+ i 1) - (cons (substring pat i (+ i 1)) toks))) - ((#\[) - (let ((j - (let search ((j (+ i 2))) - (cond - ((>= j (string-length pat)) - (slib:error 'glob:make-matcher - "unmatched [" pat)) - ((char=? #\] (string-ref pat j)) - (if (and (< (+ j 1) (string-length pat)) - (char=? #\] (string-ref pat (+ j 1)))) - (+ j 1) - j)) - (else (search (+ j 1))))))) - (loop (+ j 1) (cons (substring pat i (+ j 1)) toks)))) - (else - (let search ((j (+ i 1))) - (cond ((= j (string-length pat)) - (loop j (cons (substring pat i j) toks))) - ((memv (string-ref pat j) '(#\? #\* #\[)) - (loop j (cons (substring pat i j) toks))) - (else (search (+ j 1))))))))))) - ((pair? pat) - (for-each (lambda (elt) (or (string? elt) - (slib:error 'glob:pattern->tokens - "bad pattern" pat))) - pat) - pat) - (else (slib:error 'glob:pattern->tokens "bad pattern" pat)))) - -(define (glob:make-matcher pat ch=? ch<=?) - (define (match-end str k kmatch) - (and (= k (string-length str)) (reverse (cons k kmatch)))) - (define (match-str pstr nxt) - (let ((plen (string-length pstr))) - (lambda (str k kmatch) - (and (<= (+ k plen) (string-length str)) - (let loop ((i 0)) - (cond ((= i plen) - (nxt str (+ k plen) (cons k kmatch))) - ((ch=? (string-ref pstr i) - (string-ref str (+ k i))) - (loop (+ i 1))) - (else #f))))))) - (define (match-? nxt) - (lambda (str k kmatch) - (and (< k (string-length str)) - (nxt str (+ k 1) (cons k kmatch))))) - (define (match-set1 chrs) - (let recur ((i 0)) - (cond ((= i (string-length chrs)) - (lambda (ch) #f)) - ((and (< (+ i 2) (string-length chrs)) - (char=? #\- (string-ref chrs (+ i 1)))) - (let ((nxt (recur (+ i 3)))) - (lambda (ch) - (or (and (ch<=? ch (string-ref chrs (+ i 2))) - (ch<=? (string-ref chrs i) ch)) - (nxt ch))))) - (else - (let ((nxt (recur (+ i 1))) - (chrsi (string-ref chrs i))) - (lambda (ch) - (or (ch=? chrsi ch) (nxt ch)))))))) - (define (match-set tok nxt) - (let ((chrs (substring tok 1 (- (string-length tok) 1)))) - (if (and (positive? (string-length chrs)) - (memv (string-ref chrs 0) '(#\^ #\!))) - (let ((pred (match-set1 (substring chrs 1 (string-length chrs))))) - (lambda (str k kmatch) - (and (< k (string-length str)) - (not (pred (string-ref str k))) - (nxt str (+ k 1) (cons k kmatch))))) - (let ((pred (match-set1 chrs))) - (lambda (str k kmatch) - (and (< k (string-length str)) - (pred (string-ref str k)) - (nxt str (+ k 1) (cons k kmatch)))))))) - (define (match-* nxt) - (lambda (str k kmatch) - (let ((kmatch (cons k kmatch))) - (let loop ((kk (string-length str))) - (and (>= kk k) - (or (nxt str kk kmatch) - (loop (- kk 1)))))))) - - (let ((matcher - (let recur ((toks (glob:pattern->tokens pat))) - (if (null? toks) - match-end - (let ((pch (or (string=? (car toks) "") - (string-ref (car toks) 0)))) - (case pch - ((#\?) (match-? (recur (cdr toks)))) - ((#\*) (match-* (recur (cdr toks)))) - ((#\[) (match-set (car toks) (recur (cdr toks)))) - (else (match-str (car toks) (recur (cdr toks)))))))))) - (lambda (str) (matcher str 0 '())))) - -(define (glob:caller-with-matches pat proc ch=? ch<=?) - (define (glob:wildcard? pat) - (cond ((string=? pat "") #f) - ((memv (string-ref pat 0) '(#\* #\? #\[)) #t) - (else #f))) - (let* ((toks (glob:pattern->tokens pat)) - (wild? (map glob:wildcard? toks)) - (matcher (glob:make-matcher toks ch=? ch<=?))) - (lambda (str) - (let loop ((inds (matcher str)) - (wild? wild?) - (res '())) - (cond ((not inds) #f) - ((null? wild?) - (apply proc (reverse res))) - ((car wild?) - (loop (cdr inds) - (cdr wild?) - (cons (substring str (car inds) (cadr inds)) res))) - (else - (loop (cdr inds) (cdr wild?) res))))))) - -(define (glob:make-substituter pattern template ch=? ch<=?) - (define (wildcard? pat) - (cond ((string=? pat "") #f) - ((memv (string-ref pat 0) '(#\* #\? #\[)) #t) - (else #f))) - (define (countq val lst) - (do ((lst lst (cdr lst)) - (c 0 (if (eq? val (car lst)) (+ c 1) c))) - ((null? lst) c))) - (let ((tmpl-literals (map (lambda (tok) - (if (wildcard? tok) #f tok)) - (glob:pattern->tokens template))) - (pat-wild? (map wildcard? (glob:pattern->tokens pattern))) - (matcher (glob:make-matcher pattern ch=? ch<=?))) - (or (= (countq #t pat-wild?) (countq #f tmpl-literals)) - (slib:error 'glob:make-substituter - "number of wildcards doesn't match" pattern template)) - (lambda (str) - (let ((indices (matcher str))) - (and indices - (let loop ((inds indices) - (wild? pat-wild?) - (lits tmpl-literals) - (res '())) - (cond - ((null? lits) - (apply string-append (reverse res))) - ((car lits) - (loop inds wild? (cdr lits) (cons (car lits) res))) - ((null? wild?) ;this should never happen. - (loop '() '() lits res)) - ((car wild?) - (loop (cdr inds) (cdr wild?) (cdr lits) - (cons (substring str (car inds) (cadr inds)) - res))) - (else - (loop (cdr inds) (cdr wild?) lits res))))))))) - - -(define (glob:match?? pat) - (glob:make-matcher pat char=? char<=?)) -(define (glob:match-ci?? pat) - (glob:make-matcher pat char-ci=? char-ci<=?)) -(define filename:match?? glob:match??) -(define filename:match-ci?? glob:match-ci??) - -(define (glob:substitute?? pat templ) - (cond ((procedure? templ) - (glob:caller-with-matches pat templ char=? char<=?)) - ((string? templ) - (glob:make-substituter pat templ char=? char<=?)) - (else - (slib:error 'glob:substitute "bad second argument" templ)))) -(define (glob:substitute-ci?? pat templ) - (cond ((procedure? templ) - (glob:caller-with-matches pat templ char-ci=? char-ci<=?)) - ((string? templ) - (glob:make-substituter pat templ char-ci=? char-ci<=?)) - (else - (slib:error 'glob:substitute "bad second argument" templ)))) -(define filename:substitute?? glob:substitute??) -(define filename:substitute-ci?? glob:substitute-ci??) - -(define (replace-suffix str old new) - (let* ((f (glob:make-substituter (list "*" old) (list "*" new) - char=? char<=?)) - (g (lambda (st) - (or (f st) - (slib:error 'replace-suffix "suffix doesn't match:" - old st))))) - (if (pair? str) - (map g str) - (g str)))) diff --git a/module/slib/guile.init b/module/slib/guile.init deleted file mode 100644 index 167988352..000000000 --- a/module/slib/guile.init +++ /dev/null @@ -1,232 +0,0 @@ -;;; "guile.init" configuration template of *features* for Scheme -*-scheme-*- -;;; Author: Aubrey Jaffer -;;; -;;; This code is in the public domain. - -;;; (software-type) should be set to the generic operating system type. -;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - -(define (software-type) 'UNIX) - -;;; (scheme-implementation-type) should return the name of the scheme -;;; implementation loading this file. - -(define (scheme-implementation-type) 'Guile) - -;;; (scheme-implementation-home-page) should return a (string) URI -;;; (Uniform Resource Identifier) for this scheme implementation's home -;;; page; or false if there isn't one. - -(define (scheme-implementation-home-page) "http://www.gnu.org/software/guile/") - -;;; (scheme-implementation-version) should return a string describing -;;; the version the scheme implementation loading this file. - -(define scheme-implementation-version version) - -;;; (implementation-vicinity) should be defined to be the pathname of -;;; the directory where any auxillary files to your Scheme -;;; implementation reside. - -(define implementation-vicinity - (let ((path (string-append (%package-data-dir) "/"))) - (lambda () path))) - -;;; (library-vicinity) should be defined to be the pathname of the -;;; directory where files of Scheme library functions reside. - -(define library-vicinity - (let ((library-path - (or - ;; Use this getenv if your implementation supports it. - (getenv "SCHEME_LIBRARY_PATH") - ;; Use this path if your scheme does not support GETENV - ;; or if SCHEME_LIBRARY_PATH is not set. - (let ((this-file (port-filename (current-load-port)))) - (substring this-file 0 (- (string-length this-file) 10)))))) - (lambda () library-path))) - -;;; (home-vicinity) should return the vicinity of the user's HOME -;;; directory, the directory which typically contains files which -;;; customize a computer environment for a user. - -(define home-vicinity - (let ((home-path (getenv "HOME"))) - (lambda () home-path))) - -;;; *FEATURES* should be set to a list of symbols describing features -;;; of this implementation. Suggestions for features are: - -(define *features* - '( - source ;can load scheme source files - ;(slib:load-source "filename") - compiled ;can load compiled files - ;(slib:load-compiled "filename") - rev4-report ;conforms to - rev3-report ;conforms to - ieee-p1178 ;conforms to -; sicp ;runs code from Structure and - ;Interpretation of Computer - ;Programs by Abelson and Sussman. - rev4-optional-procedures ;LIST-TAIL, STRING->LIST, - ;LIST->STRING, STRING-COPY, - ;STRING-FILL!, LIST->VECTOR, - ;VECTOR->LIST, and VECTOR-FILL! - rev2-procedures ;SUBSTRING-MOVE-LEFT!, - ;SUBSTRING-MOVE-RIGHT!, - ;SUBSTRING-FILL!, - ;STRING-NULL?, APPEND!, 1+, - ;-1+, ?, >=? - multiarg/and- ;/ and - can take more than 2 args. - multiarg-apply ;APPLY can take more than 2 args. -; rationalize - delay ;has DELAY and FORCE - with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE - string-port ;has CALL-WITH-INPUT-STRING and - ;CALL-WITH-OUTPUT-STRING -; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF - char-ready? -; macro ;has R4RS high level macros -; macro-by-example - defmacro ;has Common Lisp DEFMACRO - eval ;R5RS two-argument eval - record ;has user defined data structures - values ;proposed multiple values - dynamic-wind ;proposed dynamic-wind - ieee-floating-point ;conforms to - full-continuation ;can return multiple times -; object-hash ;has OBJECT-HASH - - sort -; queue ;queues -; pretty-print - object->string -; format -; trace ;has macros: TRACE and UNTRACE -; compiler ;has (COMPILER) -; ed ;(ED) is editor - system ;posix (system ) - 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 - - abort - array - array-for-each - random - hash - hash-table - line-i/o - logical - promise - string-case -; syntax-case - )) - -;; time -(define difftime -) -(define offset-time +) - -;; random -(define (make-random-state . args) - (let ((seed (if (null? args) *random-state* (car args)))) - (cond ((string? seed)) - ((number? seed) (set! seed (number->string seed))) - (else (let () - (require 'object->string) - (set! seed (object->limited-string seed 50))))) - (seed->random-state seed))) - -;;; (OUTPUT-PORT-WIDTH ) -(define (output-port-width . arg) 79) - -;;; (OUTPUT-PORT-HEIGHT ) -(define (output-port-height . arg) 24) - -;;; "rationalize" adjunct procedures. -;;(define (find-ratio x e) -;; (let ((rat (rationalize x e))) -;; (list (numerator rat) (denominator rat)))) -;;(define (find-ratio-between x y) -;; (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) - -;;; Return argument -(define (identity x) x) - -;;; SLIB:EVAL is single argument eval using the top-level (user) environment. -(define (slib:eval x) - (eval x (interaction-environment))) - -(define base:eval slib:eval) -(define (defmacro:eval x) (base:eval (defmacro:expand* x))) -(define (defmacro:expand* x) - (require 'defmacroexpand) (apply defmacro:expand* x '())) - -(define (slib:eval-load evl) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (call-with-input-file - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* ) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - -(define (defmacro:load ) - (slib:eval-load defmacro:eval)) - -(define slib:warn - (lambda args - (let ((cep (current-error-port))) - (if (provided? 'trace) (print-call-stack cep)) - (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) - -;;; define an error procedure for the library -(define (slib:error . args) - (if (provided? 'trace) (print-call-stack (current-error-port))) - (apply error args)) - -;;; define these as appropriate for your system. -(define slib:tab (integer->char 9)) -(define slib:form-feed (integer->char 12)) - -;;; Support for older versions of Scheme. Not enough code for its own file. -(define t #t) -(define nil #f) - -;;; Define SLIB:EXIT to be the implementation procedure to exit or -;;; return if exitting not supported. -(define slib:exit quit) - -;;; Here for backward compatability -(define scheme-file-suffix - (let ((suffix (case (software-type) - ((NOSVE) "_scm") - (else ".scm")))) - (lambda () suffix))) - -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever -;;; suffix all the module files in SLIB have. See feature 'SOURCE. - -(define (slib:load-source f) (load (string-append f (scheme-file-suffix)))) - -;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced -;;; by compiling "foo.scm" if this implementation can compile files. -;;; See feature 'COMPILED. - -(define (slib:load-compiled f) (load-compiled-file (string-append f ".go"))) - -;;; At this point SLIB:LOAD must be able to load SLIB files. - -(define slib:load slib:load) - -(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/module/slib/hash.scm b/module/slib/hash.scm deleted file mode 100644 index ab021388e..000000000 --- a/module/slib/hash.scm +++ /dev/null @@ -1,153 +0,0 @@ -; "hash.scm", hashing functions for Scheme. -; Copyright (c) 1992, 1993, 1995 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(define (hash:hash-char-ci char n) - (modulo (char->integer (char-downcase char)) n)) - -(define hash:hash-char hash:hash-char-ci) - -(define (hash:hash-symbol sym n) - (hash:hash-string (symbol->string sym) n)) - -;;; This can overflow on implemenatations where inexacts have a larger -;;; range than exact integers. -(define hash:hash-number - (if (provided? 'inexact) - (lambda (num n) - (if (integer? num) - (modulo (if (exact? num) num (inexact->exact num)) n) - (hash:hash-string-ci - (number->string (if (exact? num) (exact->inexact num) num)) - n))) - (lambda (num n) - (if (integer? num) - (modulo num n) - (hash:hash-string-ci (number->string num) n))))) - -(define (hash:hash-string-ci str n) - (let ((len (string-length str))) - (if (> len 5) - (let loop ((h (modulo 264 n)) (i 5)) - (if (positive? i) - (loop (modulo (+ (* h 256) - (char->integer - (char-downcase - (string-ref str (modulo h len))))) - n) - (- i 1)) - h)) - (let loop ((h 0) (i (- len 1))) - (if (>= i 0) - (loop (modulo (+ (* h 256) - (char->integer - (char-downcase (string-ref str i)))) - n) - (- i 1)) - h))))) - -(define hash:hash-string hash:hash-string-ci) - -(define (hash:hash obj n) - (let hs ((d 10) (obj obj)) - (cond - ((number? obj) (hash:hash-number obj n)) - ((char? obj) (modulo (char->integer (char-downcase obj)) n)) - ((symbol? obj) (hash:hash-symbol obj n)) - ((string? obj) (hash:hash-string obj n)) - ((vector? obj) - (let ((len (vector-length obj))) - (if (> len 5) - (let lp ((h 1) (i (quotient d 2))) - (if (positive? i) - (lp (modulo (+ (* h 256) - (hs 2 (vector-ref obj (modulo h len)))) - n) - (- i 1)) - h)) - (let loop ((h (- n 1)) (i (- len 1))) - (if (>= i 0) - (loop (modulo (+ (* h 256) (hs (quotient d len) - (vector-ref obj i))) - n) - (- i 1)) - h))))) - ((pair? obj) - (if (positive? d) (modulo (+ (hs (quotient d 2) (car obj)) - (hs (quotient d 2) (cdr obj))) - n) - 1)) - (else - (modulo - (cond - ((null? obj) 256) - ((boolean? obj) (if obj 257 258)) - ((eof-object? obj) 259) - ((input-port? obj) 260) - ((output-port? obj) 261) - ((procedure? obj) 262) - ((and (provided? 'RECORD) (record? obj)) - (let* ((rtd (record-type-descriptor obj)) - (fns (record-type-field-names rtd)) - (len (length fns))) - (if (> len 5) - (let lp ((h (modulo 266 n)) (i (quotient d 2))) - (if (positive? i) - (lp (modulo - (+ (* h 256) - (hs 2 ((record-accessor - rtd (list-ref fns (modulo h len))) - obj))) - n) - (- i 1)) - h)) - (let loop ((h (- n 1)) (i (- len 1))) - (if (>= i 0) - (loop (modulo - (+ (* h 256) - (hs (quotient d len) - ((record-accessor - rtd (list-ref fns (modulo h len))) - obj))) - n) - (- i 1)) - h))))) - (else 263)) - n))))) - -(define hash hash:hash) -(define hashv hash:hash) - -;;; Object-hash is somewhat expensive on copying GC systems (like -;;; PC-Scheme and MITScheme). We use it only on strings, pairs, -;;; vectors, and records. This also allows us to use it for both -;;; hashq and hashv. - -(if (provided? 'object-hash) - (set! hashv - (if (provided? 'record) - (lambda (obj k) - (if (or (string? obj) (pair? obj) (vector? obj) (record? obj)) - (modulo (object-hash obj) k) - (hash:hash obj k))) - (lambda (obj k) - (if (or (string? obj) (pair? obj) (vector? obj)) - (modulo (object-hash obj) k) - (hash:hash obj k)))))) - -(define hashq hashv) diff --git a/module/slib/hashtab.scm b/module/slib/hashtab.scm deleted file mode 100644 index 317efe29a..000000000 --- a/module/slib/hashtab.scm +++ /dev/null @@ -1,79 +0,0 @@ -; "hashtab.scm", hash tables for Scheme. -; Copyright (c) 1992, 1993 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'hash) -(require 'alist) - -(define (predicate->hash pred) - (cond ((eq? pred eq?) hashq) - ((eq? pred eqv?) hashv) - ((eq? pred equal?) hash) - ((eq? pred =) hashv) - ((eq? pred char=?) hashv) - ((eq? pred char-ci=?) hashv) - ((eq? pred string=?) hash) - ((eq? pred string-ci=?) hash) - (else (slib:error "unknown predicate for hash" pred)))) - -(define (make-hash-table k) (make-vector k '())) - -(define (predicate->hash-asso pred) - (let ((hashfun (predicate->hash pred)) - (asso (predicate->asso pred))) - (lambda (key hashtab) - (asso key - (vector-ref hashtab (hashfun key (vector-length hashtab))))))) - -(define (hash-inquirer pred) - (let ((hashfun (predicate->hash pred)) - (ainq (alist-inquirer pred))) - (lambda (hashtab key) - (ainq (vector-ref hashtab (hashfun key (vector-length hashtab))) - key)))) - -(define (hash-associator pred) - (let ((hashfun (predicate->hash pred)) - (asso (alist-associator pred))) - (lambda (hashtab key val) - (let* ((num (hashfun key (vector-length hashtab)))) - (vector-set! hashtab num - (asso (vector-ref hashtab num) key val))) - hashtab))) - -(define (hash-remover pred) - (let ((hashfun (predicate->hash pred)) - (arem (alist-remover pred))) - (lambda (hashtab key) - (let* ((num (hashfun key (vector-length hashtab)))) - (vector-set! hashtab num - (arem (vector-ref hashtab num) key))) - hashtab))) - -(define (hash-map proc ht) - (define nht (make-vector (vector-length ht))) - (do ((i (+ -1 (vector-length ht)) (+ -1 i))) - ((negative? i) nht) - (vector-set! - nht i - (alist-map proc (vector-ref ht i))))) - -(define (hash-for-each proc ht) - (do ((i (+ -1 (vector-length ht)) (+ -1 i))) - ((negative? i)) - (alist-for-each proc (vector-ref ht i)))) diff --git a/module/slib/htmlform.scm b/module/slib/htmlform.scm deleted file mode 100644 index 66bf62ee0..000000000 --- a/module/slib/htmlform.scm +++ /dev/null @@ -1,448 +0,0 @@ -;;; "htmlform.scm" Generate HTML 2.0 forms. -*-scheme-*- -; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(require 'sort) -(require 'printf) -(require 'parameters) -(require 'object->string) -(require 'string-search) -(require 'database-utilities) -(require 'common-list-functions) - -;;;;@code{(require 'html-form)} -(define html:blank (string->symbol "")) - -;;@body Returns a string with character substitutions appropriate to -;;send @1 as an @dfn{attribute-value}. -(define (html:atval txt) ; attribute-value - (if (symbol? txt) (set! txt (symbol->string txt))) - (if (number? txt) - (number->string txt) - (string-subst (if (string? txt) txt (object->string txt)) - "&" "&" - "\"" """ - "<" "<" - ">" ">"))) - -;;@body Returns a string with character substitutions appropriate to -;;send @1 as an @dfn{plain-text}. -(define (html:plain txt) ; plain-text `Data Characters' - (cond ((eq? html:blank txt) " ") - (else - (if (symbol? txt) (set! txt (symbol->string txt))) - (if (number? txt) - (number->string txt) - (string-subst (if (string? txt) txt (object->string txt)) - "&" "&" - "<" "<" - ">" ">"))))) - -;;@body Returns a tag of meta-information suitable for passing as the -;;third argument to @code{html:head}. The tag produced is @samp{}. 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 -;; -;;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))) - (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) - (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) - (string-append - (apply string-append - (if (substring? "--" line1) - (slib:error 'html:comment "line contains --" line1) - (sprintf #f " ERROR: Method not supported: x - - -File: slib.info, Node: Priority Queues, Next: Queues, Prev: Object, Up: Data Structures - -Priority Queues ---------------- - - `(require 'priority-queue)' - - - Function: make-heap pred added field setters. - - - Macro: define-record tag (var1 var2 ...) - Defines several functions pertaining to record-name TAG: - - - Function: make-TAG var1 var2 ... - - - Function: TAG? obj - - - Function: TAG->var1 obj - - - Function: TAG->var2 obj - ... - - - Function: set-TAG-var1! obj val - - - Function: set-TAG-var2! obj val - ... - - Here is an example of its use. - - (define-record term (operator left right)) - => # - (define foo (make-term 'plus 1 2)) - => foo - (term->left foo) - => 1 - (set-term-left! foo 2345) - => # - (term->left foo) - => 2345 - - - Macro: variant-case exp (tag (var1 var2 ...) body) ... - executes the following for the matching clause: - - ((lambda (VAR1 VAR ...) BODY) - (TAG->VAR1 EXP) - (TAG->VAR2 EXP) ...) - - -File: slib.info, Node: Procedures, Next: Standards Support, Prev: Data Structures, Up: Other Packages - -Procedures -========== - - Anything that doesn't fall neatly into any of the other categories -winds up here. - -* Menu: - -* Common List Functions:: 'common-list-functions -* Tree Operations:: 'tree -* Type Coercion:: 'coerce | -* Chapter Ordering:: 'chapter-order -* Sorting:: 'sort -* Topological Sort:: Keep your socks on. -* String-Case:: 'string-case -* String Ports:: 'string-port -* String Search:: Also Search from a Port. -* Line I/O:: 'line-i/o -* Multi-Processing:: 'process -* Metric Units:: Portable manifest types for numeric values. | - - -File: slib.info, Node: Common List Functions, Next: Tree Operations, Prev: Procedures, Up: Procedures - -Common List Functions ---------------------- - - `(require 'common-list-functions)' - - The procedures below follow the Common LISP equivalents apart from -optional arguments in some cases. - -* Menu: - -* List construction:: -* Lists as sets:: -* Lists as sequences:: -* Destructive list operations:: -* Non-List functions:: - - -File: slib.info, Node: List construction, Next: Lists as sets, Prev: Common List Functions, Up: Common List Functions - -List construction -................. - - - Function: make-list k . init - `make-list' creates and returns a list of K elements. If INIT is - included, all elements in the list are initialized to INIT. - - Example: - (make-list 3) - => (# # #) - (make-list 5 'foo) - => (foo foo foo foo foo) - - - Function: list* x . y - Works like `list' except that the cdr of the last pair is the last - argument unless there is only one argument, when the result is - just that argument. Sometimes called `cons*'. E.g.: - (list* 1) - => 1 - (list* 1 2 3) - => (1 2 . 3) - (list* 1 2 '(3 4)) - => (1 2 3 4) - (list* ARGS '()) - == (list ARGS) - - - Function: copy-list lst - `copy-list' makes a copy of LST using new pairs and returns it. - Only the top level of the list is copied, i.e., pairs forming - elements of the copied list remain `eq?' to the corresponding - elements of the original; the copy is, however, not `eq?' to the - original, but is `equal?' to it. - - Example: - (copy-list '(foo foo foo)) - => (foo foo foo) - (define q '(foo bar baz bang)) - (define p q) - (eq? p q) - => #t - (define r (copy-list q)) - (eq? q r) - => #f - (equal? q r) - => #t - (define bar '(bar)) - (eq? bar (car (copy-list (list bar 'foo)))) - => #t - - -File: slib.info, Node: Lists as sets, Next: Lists as sequences, Prev: List construction, Up: Common List Functions - -Lists as sets -............. - - `eqv?' is used to test for membership by procedures which treat lists -as sets. - - - Function: adjoin e l - `adjoin' returns the adjoint of the element E and the list L. - That is, if E is in L, `adjoin' returns L, otherwise, it returns - `(cons E L)'. - - Example: - (adjoin 'baz '(bar baz bang)) - => (bar baz bang) - (adjoin 'foo '(bar baz bang)) - => (foo bar baz bang) - - - Function: union l1 l2 - `union' returns the combination of L1 and L2. Duplicates between - L1 and L2 are culled. Duplicates within L1 or within L2 may or - may not be removed. - - Example: - (union '(1 2 3 4) '(5 6 7 8)) - => (4 3 2 1 5 6 7 8) - (union '(1 2 3 4) '(3 4 5 6)) - => (2 1 3 4 5 6) - - - Function: intersection l1 l2 - `intersection' returns all elements that are in both L1 and L2. - - Example: - (intersection '(1 2 3 4) '(3 4 5 6)) - => (4 3) | - (intersection '(1 2 3 4) '(5 6 7 8)) - => () - - - Function: set-difference l1 l2 - `set-difference' returns all elements that are in L1 but not in L2. - - Example: - (set-difference '(1 2 3 4) '(3 4 5 6)) - => (2 1) | - (set-difference '(1 2 3 4) '(1 2 3 4 5 6)) - => () - - - Function: member-if pred lst - `member-if' returns LST if `(PRED ELEMENT)' is `#t' for any - ELEMENT in LST. Returns `#f' if PRED does not apply to any - ELEMENT in LST. - - Example: - (member-if vector? '(1 2 3 4)) - => #f - (member-if number? '(1 2 3 4)) - => (1 2 3 4) - - - Function: some pred lst . more-lsts - PRED is a boolean function of as many arguments as there are list - arguments to `some' i.e., LST plus any optional arguments. PRED - is applied to successive elements of the list arguments in order. - `some' returns `#t' as soon as one of these applications returns - `#t', and is `#f' if none returns `#t'. All the lists should have - the same length. - - Example: - (some odd? '(1 2 3 4)) - => #t - - (some odd? '(2 4 6 8)) - => #f - - (some > '(2 3) '(1 4)) - => #f - - - Function: every pred lst . more-lsts - `every' is analogous to `some' except it returns `#t' if every - application of PRED is `#t' and `#f' otherwise. - - Example: - (every even? '(1 2 3 4)) - => #f - - (every even? '(2 4 6 8)) - => #t - - (every > '(2 3) '(1 4)) - => #f - - - Function: notany pred . lst - `notany' is analogous to `some' but returns `#t' if no application - of PRED returns `#t' or `#f' as soon as any one does. - - - Function: notevery pred . lst - `notevery' is analogous to `some' but returns `#t' as soon as an - application of PRED returns `#f', and `#f' otherwise. - - Example: - (notevery even? '(1 2 3 4)) - => #t - - (notevery even? '(2 4 6 8)) - => #f - - - Function: list-of?? predicate | - Returns a predicate which returns true if its argument is a list | - every element of which satisfies PREDICATE. | - | - - Function: list-of?? predicate low-bound high-bound | - LOW-BOUND and HIGH-BOUND are non-negative integers. `list-of??' | - returns a predicate which returns true if its argument is a list | - of length between LOW-BOUND and HIGH-BOUND (inclusive); every | - element of which satisfies PREDICATE. | - | - - Function: list-of?? predicate bound | - BOUND is an integer. If BOUND is negative, `list-of??' returns a | - predicate which returns true if its argument is a list of length | - greater than `(- BOUND)'; every element of which satisfies | - PREDICATE. Otherwise, `list-of??' returns a predicate which | - returns true if its argument is a list of length less than or | - equal to BOUND; every element of which satisfies PREDICATE. | - | - - Function: find-if pred lst - `find-if' searches for the first ELEMENT in LST such that `(PRED - ELEMENT)' returns `#t'. If it finds any such ELEMENT in LST, - ELEMENT is returned. Otherwise, `#f' is returned. - - Example: - (find-if number? '(foo 1 bar 2)) - => 1 - - (find-if number? '(foo bar baz bang)) - => #f - - (find-if symbol? '(1 2 foo bar)) - => foo - - - Function: remove elt lst - `remove' removes all occurrences of ELT from LST using `eqv?' to - test for equality and returns everything that's left. N.B.: other - implementations (Chez, Scheme->C and T, at least) use `equal?' as - the equality test. - - Example: - (remove 1 '(1 2 1 3 1 4 1 5)) - => (5 4 3 2) | - - (remove 'foo '(bar baz bang)) - => (bang baz bar) | - - - Function: remove-if pred lst - `remove-if' removes all ELEMENTs from LST where `(PRED ELEMENT)' - is `#t' and returns everything that's left. - - Example: - (remove-if number? '(1 2 3 4)) - => () - - (remove-if even? '(1 2 3 4 5 6 7 8)) - => (7 5 3 1) | - - - Function: remove-if-not pred lst - `remove-if-not' removes all ELEMENTs from LST for which `(PRED - ELEMENT)' is `#f' and returns everything that's left. - - Example: - (remove-if-not number? '(foo bar baz)) - => () - (remove-if-not odd? '(1 2 3 4 5 6 7 8)) - => (7 5 3 1) | - - - Function: has-duplicates? lst - returns `#t' if 2 members of LST are `equal?', `#f' otherwise. - - Example: - (has-duplicates? '(1 2 3 4)) - => #f - - (has-duplicates? '(2 4 3 4)) - => #t - - The procedure `remove-duplicates' uses `member' (rather than `memv'). - - - Function: remove-duplicates lst - returns a copy of LST with its duplicate members removed. - Elements are considered duplicate if they are `equal?'. - - Example: - (remove-duplicates '(1 2 3 4)) - => (4 3 2 1) - - (remove-duplicates '(2 4 3 4)) - => (3 4 2) - - -File: slib.info, Node: Lists as sequences, Next: Destructive list operations, Prev: Lists as sets, Up: Common List Functions - -Lists as sequences -.................. - - - Function: position obj lst - `position' returns the 0-based position of OBJ in LST, or `#f' if - OBJ does not occur in LST. - - Example: - (position 'foo '(foo bar baz bang)) - => 0 - (position 'baz '(foo bar baz bang)) - => 2 - (position 'oops '(foo bar baz bang)) - => #f - - - Function: reduce p lst - `reduce' combines all the elements of a sequence using a binary - operation (the combination is left-associative). For example, - using `+', one can add up all the elements. `reduce' allows you to - apply a function which accepts only two arguments to more than 2 - objects. Functional programmers usually refer to this as "foldl". - `collect:reduce' (*note Collections::) provides a version of - `collect' generalized to collections. - - Example: - (reduce + '(1 2 3 4)) - => 10 - (define (bad-sum . l) (reduce + l)) - (bad-sum 1 2 3 4) - == (reduce + (1 2 3 4)) - == (+ (+ (+ 1 2) 3) 4) - => 10 - (bad-sum) - == (reduce + ()) - => () - (reduce string-append '("hello" "cruel" "world")) - == (string-append (string-append "hello" "cruel") "world") - => "hellocruelworld" - (reduce anything '()) - => () - (reduce anything '(x)) - => x - - What follows is a rather non-standard implementation of `reverse' - in terms of `reduce' and a combinator elsewhere called "C". - - ;;; Contributed by Jussi Piitulainen (jpiitula@ling.helsinki.fi) - - (define commute - (lambda (f) - (lambda (x y) - (f y x)))) - - (define reverse - (lambda (args) - (reduce-init (commute cons) '() args))) - - - Function: reduce-init p init lst - `reduce-init' is the same as reduce, except that it implicitly - inserts INIT at the start of the list. `reduce-init' is preferred - if you want to handle the null list, the one-element, and lists - with two or more elements consistently. It is common to use the - operator's idempotent as the initializer. Functional programmers - usually call this "foldl". - - Example: - (define (sum . l) (reduce-init + 0 l)) - (sum 1 2 3 4) - == (reduce-init + 0 (1 2 3 4)) - == (+ (+ (+ (+ 0 1) 2) 3) 4) - => 10 - (sum) - == (reduce-init + 0 '()) - => 0 - - (reduce-init string-append "@" '("hello" "cruel" "world")) - == - (string-append (string-append (string-append "@" "hello") - "cruel") - "world") - => "@hellocruelworld" - - Given a differentiation of 2 arguments, `diff', the following will - differentiate by any number of variables. - (define (diff* exp . vars) - (reduce-init diff exp vars)) - - Example: - ;;; Real-world example: Insertion sort using reduce-init. - - (define (insert l item) - (if (null? l) - (list item) - (if (< (car l) item) - (cons (car l) (insert (cdr l) item)) - (cons item l)))) - (define (insertion-sort l) (reduce-init insert '() l)) - - (insertion-sort '(3 1 4 1 5) - == (reduce-init insert () (3 1 4 1 5)) - == (insert (insert (insert (insert (insert () 3) 1) 4) 1) 5) - == (insert (insert (insert (insert (3)) 1) 4) 1) 5) - == (insert (insert (insert (1 3) 4) 1) 5) - == (insert (insert (1 3 4) 1) 5) - == (insert (1 1 3 4) 5) - => (1 1 3 4 5) - - - Function: last lst n - `last' returns the last N elements of LST. N must be a - non-negative integer. - - Example: - (last '(foo bar baz bang) 2) - => (baz bang) - (last '(1 2 3) 0) - => 0 - - - Function: butlast lst n - `butlast' returns all but the last N elements of LST. - - Example: - (butlast '(a b c d) 3) - => (a) - (butlast '(a b c d) 4) - => () - -`last' and `butlast' split a list into two parts when given identical -arugments. - (last '(a b c d e) 2) - => (d e) - (butlast '(a b c d e) 2) - => (a b c) - - - Function: nthcdr n lst - `nthcdr' takes N `cdr's of LST and returns the result. Thus - `(nthcdr 3 LST)' == `(cdddr LST)' - - Example: - (nthcdr 2 '(a b c d)) - => (c d) - (nthcdr 0 '(a b c d)) - => (a b c d) - - - Function: butnthcdr n lst - `butnthcdr' returns all but the nthcdr N elements of LST. - - Example: - (butnthcdr 3 '(a b c d)) - => (a b c) - (butnthcdr 4 '(a b c d)) - => (a b c d) | - -`nthcdr' and `butnthcdr' split a list into two parts when given -identical arugments. - (nthcdr 2 '(a b c d e)) - => (c d e) - (butnthcdr 2 '(a b c d e)) - => (a b) - - -File: slib.info, Node: Destructive list operations, Next: Non-List functions, Prev: Lists as sequences, Up: Common List Functions - -Destructive list operations -........................... - - These procedures may mutate the list they operate on, but any such -mutation is undefined. - - - Procedure: nconc args - `nconc' destructively concatenates its arguments. (Compare this - with `append', which copies arguments rather than destroying them.) - Sometimes called `append!' (*note Rev2 Procedures::). - - Example: You want to find the subsets of a set. Here's the - obvious way: - - (define (subsets set) - (if (null? set) - '(()) - (append (mapcar (lambda (sub) (cons (car set) sub)) - (subsets (cdr set))) - (subsets (cdr set))))) - But that does way more consing than you need. Instead, you could - replace the `append' with `nconc', since you don't have any need - for all the intermediate results. - - Example: - (define x '(a b c)) - (define y '(d e f)) - (nconc x y) - => (a b c d e f) - x - => (a b c d e f) - - `nconc' is the same as `append!' in `sc2.scm'. - - - Procedure: nreverse lst - `nreverse' reverses the order of elements in LST by mutating - `cdr's of the list. Sometimes called `reverse!'. - - Example: - (define foo '(a b c)) - (nreverse foo) - => (c b a) - foo - => (a) - - Some people have been confused about how to use `nreverse', - thinking that it doesn't return a value. It needs to be pointed - out that - (set! lst (nreverse lst)) - - is the proper usage, not - (nreverse lst) - The example should suffice to show why this is the case. - - - Procedure: delete elt lst - - Procedure: delete-if pred lst - - Procedure: delete-if-not pred lst - Destructive versions of `remove' `remove-if', and `remove-if-not'. - - Example: - (define lst '(foo bar baz bang)) - (delete 'foo lst) - => (bar baz bang) - lst - => (foo bar baz bang) - - (define lst '(1 2 3 4 5 6 7 8 9)) - (delete-if odd? lst) - => (2 4 6 8) - lst - => (1 2 4 6 8) - - Some people have been confused about how to use `delete', - `delete-if', and `delete-if', thinking that they dont' return a - value. It needs to be pointed out that - (set! lst (delete el lst)) - - is the proper usage, not - (delete el lst) - The examples should suffice to show why this is the case. - - -File: slib.info, Node: Non-List functions, Prev: Destructive list operations, Up: Common List Functions - -Non-List functions -.................. - - - Function: and? . args - `and?' checks to see if all its arguments are true. If they are, - `and?' returns `#t', otherwise, `#f'. (In contrast to `and', this - is a function, so all arguments are always evaluated and in an - unspecified order.) - - Example: - (and? 1 2 3) - => #t - (and #f 1 2) - => #f - - - Function: or? . args - `or?' checks to see if any of its arguments are true. If any is - true, `or?' returns `#t', and `#f' otherwise. (To `or' as `and?' - is to `and'.) - - Example: - (or? 1 2 #f) - => #t - (or? #f #f #f) - => #f - - - Function: atom? object - Returns `#t' if OBJECT is not a pair and `#f' if it is pair. - (Called `atom' in Common LISP.) - (atom? 1) - => #t - (atom? '(1 2)) - => #f - (atom? #(1 2)) ; dubious! - => #t - | - -File: slib.info, Node: Tree Operations, Next: Type Coercion, Prev: Common List Functions, Up: Procedures - | -Tree operations ---------------- - - `(require 'tree)' - - These are operations that treat lists a representations of trees. - - - Function: subst new old tree - - Function: substq new old tree - - Function: substv new old tree - `subst' makes a copy of TREE, substituting NEW for every subtree - or leaf of TREE which is `equal?' to OLD and returns a modified - tree. The original TREE is unchanged, but may share parts with - the result. - - `substq' and `substv' are similar, but test against OLD using - `eq?' and `eqv?' respectively. - - Examples: - (substq 'tempest 'hurricane '(shakespeare wrote (the hurricane))) - => (shakespeare wrote (the tempest)) - (substq 'foo '() '(shakespeare wrote (twelfth night))) - => (shakespeare wrote (twelfth night . foo) . foo) - (subst '(a . cons) '(old . pair) - '((old . spice) ((old . shoes) old . pair) (old . pair))) - => ((old . spice) ((old . shoes) a . cons) (a . cons)) - - - Function: copy-tree tree - Makes a copy of the nested list structure TREE using new pairs and - returns it. All levels are copied, so that none of the pairs in - the tree are `eq?' to the original ones - only the leaves are. - - Example: - (define bar '(bar)) - (copy-tree (list bar 'foo)) - => ((bar) foo) - (eq? bar (car (copy-tree (list bar 'foo)))) - => #f - - -File: slib.info, Node: Type Coercion, Next: Chapter Ordering, Prev: Tree Operations, Up: Procedures - | -Type Coercion | -------------- | - | - `(require 'coerce)' | - | - - Function: type-of obj | - Returns a symbol name for the type of OBJ. | - | - - Function: coerce obj result-type | - Converts and returns OBJ of type `char', `number', `string', | - `symbol', `list', or `vector' to RESULT-TYPE (which must be one of | - these symbols). | - | - -File: slib.info, Node: Chapter Ordering, Next: Sorting, Prev: Type Coercion, Up: Procedures - | -Chapter Ordering ----------------- - - `(require 'chapter-order)' - - The `chap:' functions deal with strings which are ordered like -chapter numbers (or letters) in a book. Each section of the string -consists of consecutive numeric or consecutive aphabetic characters of -like case. - - - Function: chap:string #t - (chap:string #t - (chap:string #t - - - Function: chap:string>? string1 string2 - - Function: chap:string<=? string1 string2 - - Function: chap:string>=? string1 string2 - Implement the corresponding chapter-order predicates. - - - Function: chap:next-string string - Returns the next string in the _chapter order_. If STRING has no - alphabetic or numeric characters, `(string-append STRING "0")' is - returnd. The argument to chap:next-string will always be - `chap:string "a.10" - (chap:next-string "4c") => "4d" - (chap:next-string "4z") => "4aa" - (chap:next-string "Revised^{4}") => "Revised^{5}" - - -File: slib.info, Node: Sorting, Next: Topological Sort, Prev: Chapter Ordering, Up: Procedures - -Sorting -------- - - `(require 'sort)' - - Many Scheme systems provide some kind of sorting functions. They do -not, however, always provide the _same_ sorting functions, and those -that I have had the opportunity to test provided inefficient ones (a -common blunder is to use quicksort which does not perform well). - - Because `sort' and `sort!' are not in the standard, there is very -little agreement about what these functions look like. For example, -Dybvig says that Chez Scheme provides - (merge predicate list1 list2) - (merge! predicate list1 list2) - (sort predicate list) - (sort! predicate list) - -while MIT Scheme 7.1, following Common LISP, offers unstable - (sort list predicate) - -TI PC Scheme offers - (sort! list/vector predicate?) - -and Elk offers - (sort list/vector predicate?) - (sort! list/vector predicate?) - - Here is a comprehensive catalogue of the variations I have found. - - 1. Both `sort' and `sort!' may be provided. - - 2. `sort' may be provided without `sort!'. - - 3. `sort!' may be provided without `sort'. - - 4. Neither may be provided. - - 5. The sequence argument may be either a list or a vector. - - 6. The sequence argument may only be a list. - - 7. The sequence argument may only be a vector. - - 8. The comparison function may be expected to behave like `<'. - - 9. The comparison function may be expected to behave like `<='. - - 10. The interface may be `(sort predicate? sequence)'. - - 11. The interface may be `(sort sequence predicate?)'. - - 12. The interface may be `(sort sequence &optional (predicate? <))'. - - 13. The sort may be stable. - - 14. The sort may be unstable. - - All of this variation really does not help anybody. A nice simple -merge sort is both stable and fast (quite a lot faster than _quick_ -sort). - - I am providing this source code with no restrictions at all on its use -(but please retain D.H.D.Warren's credit for the original idea). You -may have to rename some of these functions in order to use them in a -system which already provides incompatible or inferior sorts. For each -of the functions, only the top-level define needs to be edited to do -that. - - I could have given these functions names which would not clash with -any Scheme that I know of, but I would like to encourage implementors to -converge on a single interface, and this may serve as a hint. The -argument order for all functions has been chosen to be as close to -Common LISP as made sense, in order to avoid NIH-itis. - - Each of the five functions has a required _last_ parameter which is a -comparison function. A comparison function `f' is a function of 2 -arguments which acts like `<'. For example, - - (not (f x x)) - (and (f x y) (f y z)) == (f x z) - - The standard functions `<', `>', `char?', `char-ci?', `string?', `string-ci?' -are suitable for use as comparison functions. Think of `(less? x y)' -as saying when `x' must _not_ precede `y'. - - - Function: sorted? sequence less? - Returns `#t' when the sequence argument is in non-decreasing order - according to LESS? (that is, there is no adjacent pair `... x y - ...' for which `(less? y x)'). - - Returns `#f' when the sequence contains at least one out-of-order - pair. It is an error if the sequence is neither a list nor a - vector. - - - Function: merge list1 list2 less? - This merges two lists, producing a completely new list as result. - I gave serious consideration to producing a Common-LISP-compatible - version. However, Common LISP's `sort' is our `sort!' (well, in - fact Common LISP's `stable-sort' is our `sort!', merge sort is - _fast_ as well as stable!) so adapting CL code to Scheme takes a - bit of work anyway. I did, however, appeal to CL to determine the - _order_ of the arguments. - - - Procedure: merge! list1 list2 less? - Merges two lists, re-using the pairs of LIST1 and LIST2 to build - the result. If the code is compiled, and LESS? constructs no new - pairs, no pairs at all will be allocated. The first pair of the - result will be either the first pair of LIST1 or the first pair of - LIST2, but you can't predict which. - - The code of `merge' and `merge!' could have been quite a bit - simpler, but they have been coded to reduce the amount of work - done per iteration. (For example, we only have one `null?' test - per iteration.) - - - Function: sort sequence less? - Accepts either a list or a vector, and returns a new sequence - which is sorted. The new sequence is the same type as the input. - Always `(sorted? (sort sequence less?) less?)'. The original - sequence is not altered in any way. The new sequence shares its - _elements_ with the old one; no elements are copied. - - - Procedure: sort! sequence less? - Returns its sorted result in the original boxes. If the original - sequence is a list, no new storage is allocated at all. If the - original sequence is a vector, the sorted elements are put back in - the same vector. - - Some people have been confused about how to use `sort!', thinking - that it doesn't return a value. It needs to be pointed out that - (set! slist (sort! slist <)) - - is the proper usage, not - (sort! slist <) - - Note that these functions do _not_ accept a CL-style `:key' argument. -A simple device for obtaining the same expressiveness is to define - (define (keyed less? key) - (lambda (x y) (less? (key x) (key y)))) - -and then, when you would have written - (sort a-sequence #'my-less :key #'my-key) - -in Common LISP, just write - (sort! a-sequence (keyed my-less? my-key)) - -in Scheme. - - -File: slib.info, Node: Topological Sort, Next: String-Case, Prev: Sorting, Up: Procedures - -Topological Sort ----------------- - - `(require 'topological-sort)' or `(require 'tsort)' - -The algorithm is inspired by Cormen, Leiserson and Rivest (1990) -`Introduction to Algorithms', chapter 23. - - - Function: tsort dag pred - - Function: topological-sort dag pred - where - DAG - is a list of sublists. The car of each sublist is a vertex. - The cdr is the adjacency list of that vertex, i.e. a list of - all vertices to which there exists an edge from the car - vertex. - - PRED - is one of `eq?', `eqv?', `equal?', `=', `char=?', - `char-ci=?', `string=?', or `string-ci=?'. - - Sort the directed acyclic graph DAG so that for every edge from - vertex U to V, U will come before V in the resulting list of - vertices. - - Time complexity: O (|V| + |E|) - - Example (from Cormen): - Prof. Bumstead topologically sorts his clothing when getting - dressed. The first argument to `tsort' describes which - garments he needs to put on before others. (For example, - Prof Bumstead needs to put on his shirt before he puts on his - tie or his belt.) `tsort' gives the correct order of - dressing: - - (require 'tsort) - (tsort '((shirt tie belt) - (tie jacket) - (belt jacket) - (watch) - (pants shoes belt) - (undershorts pants shoes) - (socks shoes)) - eq?) - => - (socks undershorts pants shoes watch shirt belt tie jacket) - - -File: slib.info, Node: String-Case, Next: String Ports, Prev: Topological Sort, Up: Procedures - -String-Case ------------ - - `(require 'string-case)' - - - Procedure: string-upcase str - - Procedure: string-downcase str - - Procedure: string-capitalize str - The obvious string conversion routines. These are non-destructive. - - - Function: string-upcase! str - - Function: string-downcase! str - - Function: string-captialize! str - The destructive versions of the functions above. - - - Function: string-ci->symbol str - Converts string STR to a symbol having the same case as if the - symbol had been `read'. - - - Function: symbol-append obj1 ... | - Converts OBJ1 ... to strings, appends them, and converts to a | - symbol which is returned. Strings and numbers are converted to | - read's symbol case; the case of symbol characters is not changed. | - #f is converted to the empty string (symbol). | - | - -File: slib.info, Node: String Ports, Next: String Search, Prev: String-Case, Up: Procedures - -String Ports ------------- - - `(require 'string-port)' - - - Procedure: call-with-output-string proc - PROC must be a procedure of one argument. This procedure calls - PROC with one argument: a (newly created) output port. When the - function returns, the string composed of the characters written - into the port is returned. - - - Procedure: call-with-input-string string proc - PROC must be a procedure of one argument. This procedure calls - PROC with one argument: an (newly created) input port from which - STRING's contents may be read. When PROC returns, the port is - closed and the value yielded by the procedure PROC is returned. - - -File: slib.info, Node: String Search, Next: Line I/O, Prev: String Ports, Up: Procedures - -String Search -------------- - - `(require 'string-search)' - - - Procedure: string-index string char - - Procedure: string-index-ci string char - Returns the index of the first occurence of CHAR within STRING, or - `#f' if the STRING does not contain a character CHAR. - - - Procedure: string-reverse-index string char - - Procedure: string-reverse-index-ci string char - Returns the index of the last occurence of CHAR within STRING, or - `#f' if the STRING does not contain a character CHAR. - - - procedure: substring? pattern string - - procedure: substring-ci? pattern string - Searches STRING to see if some substring of STRING is equal to - PATTERN. `substring?' returns the index of the first character of - the first substring of STRING that is equal to PATTERN; or `#f' if - STRING does not contain PATTERN. - - (substring? "rat" "pirate") => 2 - (substring? "rat" "outrage") => #f - (substring? "" any-string) => 0 - - - Procedure: find-string-from-port? str in-port max-no-chars - Looks for a string STR within the first MAX-NO-CHARS chars of the - input port IN-PORT. - - - Procedure: find-string-from-port? str in-port - When called with two arguments, the search span is limited by the - end of the input stream. - - - Procedure: find-string-from-port? str in-port char - Searches up to the first occurrence of character CHAR in STR. - - - Procedure: find-string-from-port? str in-port proc - Searches up to the first occurrence of the procedure PROC - returning non-false when called with a character (from IN-PORT) - argument. - - When the STR is found, `find-string-from-port?' returns the number - of characters it has read from the port, and the port is set to - read the first char after that (that is, after the STR) The - function returns `#f' when the STR isn't found. - - `find-string-from-port?' reads the port _strictly_ sequentially, - and does not perform any buffering. So `find-string-from-port?' - can be used even if the IN-PORT is open to a pipe or other - communication channel. - - - Function: string-subst txt old1 new1 ... - Returns a copy of string TXT with all occurrences of string OLD1 - in TXT replaced with NEW1, OLD2 replaced with NEW2 .... - - -File: slib.info, Node: Line I/O, Next: Multi-Processing, Prev: String Search, Up: Procedures - -Line I/O --------- - - `(require 'line-i/o)' - - - Function: read-line - - Function: read-line port - Returns a string of the characters up to, but not including a - newline or end of file, updating PORT to point to the character - following the newline. If no characters are available, an end of - file object is returned. The PORT argument may be omitted, in - which case it defaults to the value returned by - `current-input-port'. - - - Function: read-line! string - - Function: read-line! string port - Fills STRING with characters up to, but not including a newline or - end of file, updating the PORT to point to the last character read - or following the newline if it was read. If no characters are - available, an end of file object is returned. If a newline or end - of file was found, the number of characters read is returned. - Otherwise, `#f' is returned. The PORT argument may be omitted, in - which case it defaults to the value returned by - `current-input-port'. - - - Function: write-line string - - Function: write-line string port - Writes STRING followed by a newline to the given PORT and returns - an unspecified value. The PORT argument may be omitted, in which - case it defaults to the value returned by `current-input-port'. - - - Function: display-file path - - Function: display-file path port - Displays the contents of the file named by PATH to PORT. The PORT - argument may be ommited, in which case it defaults to the value - returned by `current-output-port'. - - -File: slib.info, Node: Multi-Processing, Next: Metric Units, Prev: Line I/O, Up: Procedures - | -Multi-Processing ----------------- - - `(require 'process)' - - This module implements asynchronous (non-polled) time-sliced -multi-processing in the SCM Scheme implementation using procedures -`alarm' and `alarm-interrupt'. Until this is ported to another -implementation, consider it an example of writing schedulers in Scheme. - - - Procedure: add-process! proc - Adds proc, which must be a procedure (or continuation) capable of - accepting accepting one argument, to the `process:queue'. The - value returned is unspecified. The argument to PROC should be - ignored. If PROC returns, the process is killed. - - - Procedure: process:schedule! - Saves the current process on `process:queue' and runs the next - process from `process:queue'. The value returned is unspecified. - - - Procedure: kill-process! - Kills the current process and runs the next process from - `process:queue'. If there are no more processes on - `process:queue', `(slib:exit)' is called (*note System::). - - -File: slib.info, Node: Metric Units, Prev: Multi-Processing, Up: Procedures - | -Metric Units | ------------- | - | - `(require 'metric-units)' | - | - | - | - "Metric Interchange Format" is a character string encoding for | -numerical values and units which: | - | - * is unambiguous in all locales; | - | - * uses only [TOG] "Portable Character Set" characters matching "Basic | - Latin" characters in Plane 0 of the Universal Character Set [UCS]; | - | - * is transparent to [UTF-7] and [UTF-8] UCS transformation formats; | - | - * is human readable and writable; | - | - * is machine readable and writable; | - | - * incorporates SI prefixes and units; | - | - * incorporates [ISO 6093] numbers; and | - | - * incorporates [IEC 60027-2] binary prefixes. | - | - In the expression for the value of a quantity, the unit symbol is | -placed after the numerical value. A dot (PERIOD, `.') is placed between | -the numerical value and the unit symbol. | - | - Within a compound unit, each of the base and derived symbols can | -optionally have an attached SI prefix. | - | - Unit symbols formed from other unit symbols by multiplication are | -indicated by means of a dot (PERIOD, `.') placed between them. | - | - Unit symbols formed from other unit symbols by division are indicated | -by means of a SOLIDUS (`/') or negative exponents. The SOLIDUS must | -not be repeated in the same compound unit unless contained within a | -parenthesized subexpression. | - | - The grouping formed by a prefix symbol attached to a unit symbol | -constitutes a new inseparable symbol (forming a multiple or submultiple | -of the unit concerned) which can be raised to a positive or negative | -power and which can be combined with other unit symbols to form compound | -unit symbols. | - | - The grouping formed by surrounding compound unit symbols with | -parentheses (`(' and `)') constitutes a new inseparable symbol which | -can be raised to a positive or negative power and which can be combined | -with other unit symbols to form compound unit symbols. | - | - Compound prefix symbols, that is, prefix symbols formed by the | -juxtaposition of two or more prefix symbols, are not permitted. | - | - Prefix symbols are not used with the time-related unit symbols min | -(minute), h (hour), d (day). No prefix symbol may be used with dB | -(decibel). Only submultiple prefix symbols may be used with the unit | -symbols L (liter), Np (neper), o (degree), oC (degree Celsius), rad | -(radian), and sr (steradian). Submultiple prefix symbols may not be | -used with the unit symbols t (metric ton), r (revolution), or Bd (baud). | - | - A unit exponent follows the unit, separated by a CIRCUMFLEX (`^'). | -Exponents may be positive or negative. Fractional exponents must be | -parenthesized. | - | -SI Prefixes | -........... | - | - Factor Name Symbol | Factor Name Symbol | - ====== ==== ====== | ====== ==== ====== | - 1e24 yotta Y | 1e-1 deci d | - 1e21 zetta Z | 1e-2 centi c | - 1e18 exa E | 1e-3 milli m | - 1e15 peta P | 1e-6 micro u | - 1e12 tera T | 1e-9 nano n | - 1e9 giga G | 1e-12 pico p | - 1e6 mega M | 1e-15 femto f | - 1e3 kilo k | 1e-18 atto a | - 1e2 hecto h | 1e-21 zepto z | - 1e1 deka da | 1e-24 yocto y | - | -Binary Prefixes | -............... | - | - These binary prefixes are valid only with the units B (byte) and bit. | -However, decimal prefixes can also be used with bit; and decimal | -multiple (not submultiple) prefixes can also be used with B (byte). | - | - Factor (power-of-2) Name Symbol | - ====== ============ ==== ====== | - 1.152921504606846976e18 (2^60) exbi Ei | - 1.125899906842624e15 (2^50) pebi Pi | - 1.099511627776e12 (2^40) tebi Ti | - 1.073741824e9 (2^30) gibi Gi | - 1.048576e6 (2^20) mebi Mi | - 1.024e3 (2^10) kibi Ki | - | -Unit Symbols | -............ | - | - Type of Quantity Name Symbol Equivalent | - ================ ==== ====== ========== | - time second s | - time minute min = 60.s | - time hour h = 60.min | - time day d = 24.h | - frequency hertz Hz s^-1 | - signaling rate baud Bd s^-1 | - length meter m | - volume liter L dm^3 | - plane angle radian rad | - solid angle steradian sr rad^2 | - plane angle revolution * r = 6.283185307179586.rad | - plane angle degree * o = 2.777777777777778e-3.r | - information capacity bit bit | - information capacity byte, octet B = 8.bit | - mass gram g | - mass ton t Mg | - mass unified atomic mass unit u = 1.66053873e-27.kg | - amount of substance mole mol | - catalytic activity katal kat mol/s | - thermodynamic temperature kelvin K | - centigrade temperature degree Celsius oC | - luminous intensity candela cd | - luminous flux lumen lm cd.sr | - illuminance lux lx lm/m^2 | - force newton N m.kg.s^-2 | - pressure, stress pascal Pa N/m^2 | - energy, work, heat joule J N.m | - energy electronvolt eV = 1.602176462e-19.J | - power, radiant flux watt W J/s | - logarithm of power ratio neper Np | - logarithm of power ratio decibel * dB = 0.1151293.Np | - electric current ampere A | - electric charge coulomb C s.A | - electric potential, EMF volt V W/A | - capacitance farad F C/V | - electric resistance ohm Ohm V/A | - electric conductance siemens S A/V | - magnetic flux weber Wb V.s | - magnetic flux density tesla T Wb/m^2 | - inductance henry H Wb/A | - radionuclide activity becquerel Bq s^-1 | - absorbed dose energy gray Gy m^2.s^-2 | - dose equivalent sievert Sv m^2.s^-2 | - | - * The formulas are: | - | - * r/rad = 8 * atan(1) | - | - * o/r = 1 / 360 | - | - * db/Np = ln(10) / 20 | - | - - Function: si:conversion-factor to-unit from-unit | - If the strings FROM-UNIT and TO-UNIT express valid unit | - expressions for quantities of the same unit-dimensions, then the | - value returned by `si:conversion-factor' will be such that | - multiplying a numerical value expressed in FROM-UNITs by the | - returned conversion factor yields the numerical value expressed in | - TO-UNITs. | - | - Otherwise, `si:conversion-factor' returns: | - | - -3 | - if neither FROM-UNIT nor TO-UNIT is a syntactically valid | - unit. | - | - -2 | - if FROM-UNIT is not a syntactically valid unit. | - | - -1 | - if TO-UNIT is not a syntactically valid unit. | - | - 0 | - if linear conversion (by a factor) is not possible. | - | - | - (si:conversion-factor "km/s" "m/s" ) => 0.001 | - (si:conversion-factor "N" "m/s" ) => 0 | - (si:conversion-factor "moC" "oC" ) => 1000 | - (si:conversion-factor "mK" "oC" ) => 0 | - (si:conversion-factor "rad" "o" ) => 0.0174533 | - (si:conversion-factor "K" "o" ) => 0 | - (si:conversion-factor "K" "K" ) => 1 | - (si:conversion-factor "oK" "oK" ) => -3 | - (si:conversion-factor "" "s/s" ) => 1 | - (si:conversion-factor "km/h" "mph" ) => -2 | - | - -File: slib.info, Node: Standards Support, Next: Session Support, Prev: Procedures, Up: Other Packages - | -Standards Support -================= - -* Menu: - -* With-File:: 'with-file -* Transcripts:: 'transcript -* Rev2 Procedures:: 'rev2-procedures -* Rev4 Optional Procedures:: 'rev4-optional-procedures -* Multi-argument / and -:: 'multiarg/and- -* Multi-argument Apply:: 'multiarg-apply -* Rationalize:: 'rationalize -* Promises:: 'promise -* Dynamic-Wind:: 'dynamic-wind -* Eval:: 'eval -* Values:: 'values - - -File: slib.info, Node: With-File, Next: Transcripts, Prev: Standards Support, Up: Standards Support - -With-File ---------- - - `(require 'with-file)' - - - Function: with-input-from-file file thunk - - Function: with-output-to-file file thunk - Description found in R4RS. - - -File: slib.info, Node: Transcripts, Next: Rev2 Procedures, Prev: With-File, Up: Standards Support - -Transcripts ------------ - - `(require 'transcript)' - - - Function: transcript-on filename - - Function: transcript-off filename - Redefines `read-char', `read', `write-char', `write', `display', - and `newline'. - - -File: slib.info, Node: Rev2 Procedures, Next: Rev4 Optional Procedures, Prev: Transcripts, Up: Standards Support - -Rev2 Procedures ---------------- - - `(require 'rev2-procedures)' - - The procedures below were specified in the `Revised^2 Report on -Scheme'. *N.B.*: The symbols `1+' and `-1+' are not `R4RS' syntax. -Scheme->C, for instance, barfs on this module. - - - Procedure: substring-move-left! string1 start1 end1 string2 start2 - - Procedure: substring-move-right! string1 start1 end1 string2 start2 - STRING1 and STRING2 must be a strings, and START1, START2 and END1 - must be exact integers satisfying - - 0 <= START1 <= END1 <= (string-length STRING1) - 0 <= START2 <= END1 - START1 + START2 <= (string-length STRING2) - - `substring-move-left!' and `substring-move-right!' store - characters of STRING1 beginning with index START1 (inclusive) and - ending with index END1 (exclusive) into STRING2 beginning with - index START2 (inclusive). - - `substring-move-left!' stores characters in time order of - increasing indices. `substring-move-right!' stores characters in - time order of increasing indeces. - - - Procedure: substring-fill! string start end char - Fills the elements START-END of STRING with the character CHAR. - - - Function: string-null? str - == `(= 0 (string-length STR))' - - - Procedure: append! . pairs - Destructively appends its arguments. Equivalent to `nconc'. - - - Function: 1+ n - Adds 1 to N. - - - Function: -1+ n - Subtracts 1 from N. - - - Function: ? - - Function: >=? - These are equivalent to the procedures of the same name but - without the trailing `?'. - - -File: slib.info, Node: Rev4 Optional Procedures, Next: Multi-argument / and -, Prev: Rev2 Procedures, Up: Standards Support - -Rev4 Optional Procedures ------------------------- - - `(require 'rev4-optional-procedures)' - - For the specification of these optional procedures, *Note Standard -procedures: (r4rs)Standard procedures. - - - Function: list-tail l p - - - Function: string->list s - - - Function: list->string l - - - Function: string-copy - - - Procedure: string-fill! s obj - - - Function: list->vector l - - - Function: vector->list s - - - Procedure: vector-fill! s obj - - -File: slib.info, Node: Multi-argument / and -, Next: Multi-argument Apply, Prev: Rev4 Optional Procedures, Up: Standards Support - -Multi-argument / and - ----------------------- - - `(require 'mutliarg/and-)' - - For the specification of these optional forms, *Note Numerical -operations: (r4rs)Numerical operations. The `two-arg:'* forms are only -defined if the implementation does not support the many-argument forms. - - - Function: two-arg:/ n1 n2 - The original two-argument version of `/'. - - - Function: / divident . divisors - - - Function: two-arg:- n1 n2 - The original two-argument version of `-'. - - - Function: - minuend . subtrahends - - -File: slib.info, Node: Multi-argument Apply, Next: Rationalize, Prev: Multi-argument / and -, Up: Standards Support - -Multi-argument Apply --------------------- - - `(require 'multiarg-apply)' - -For the specification of this optional form, *Note Control features: -(r4rs)Control features. - - - Function: two-arg:apply proc l - The implementation's native `apply'. Only defined for - implementations which don't support the many-argument version. - - - Function: apply proc . args - - -File: slib.info, Node: Rationalize, Next: Promises, Prev: Multi-argument Apply, Up: Standards Support - -Rationalize ------------ - - `(require 'rationalize)' - - The procedure "rationalize" is interesting because most programming -languages do not provide anything analogous to it. Thanks to Alan -Bawden for contributing this algorithm. - - - Function: rationalize x y - Computes the correct result for exact arguments (provided the - implementation supports exact rational numbers of unlimited - precision); and produces a reasonable answer for inexact arguments - when inexact arithmetic is implemented using floating-point. - - `Rationalize' has limited use in implementations lacking exact -(non-integer) rational numbers. The following procedures return a list -of the numerator and denominator. - - - Function: find-ratio x y - `find-ratio' returns the list of the _simplest_ numerator and - denominator whose quotient differs from X by no more than Y. - - (find-ratio 3/97 .0001) => (3 97) | - (find-ratio 3/97 .001) => (1 32) | - - - Function: find-ratio-between x y - `find-ratio-between' returns the list of the _simplest_ numerator - and denominator between X and Y. - - (find-ratio-between 2/7 3/5) => (1 2) | - (find-ratio-between -3/5 -2/7) => (-1 2) | - - -File: slib.info, Node: Promises, Next: Dynamic-Wind, Prev: Rationalize, Up: Standards Support - -Promises --------- - - `(require 'promise)' - - - Function: make-promise proc - - Change occurrences of `(delay EXPRESSION)' to `(make-promise (lambda -() EXPRESSION))' and `(define force promise:force)' to implement -promises if your implementation doesn't support them (*note Control -features: (r4rs)Control features.). - - -File: slib.info, Node: Dynamic-Wind, Next: Eval, Prev: Promises, Up: Standards Support - -Dynamic-Wind ------------- - - `(require 'dynamic-wind)' - - This facility is a generalization of Common LISP `unwind-protect', -designed to take into account the fact that continuations produced by -`call-with-current-continuation' may be reentered. - - - Procedure: dynamic-wind thunk1 thunk2 thunk3 - The arguments THUNK1, THUNK2, and THUNK3 must all be procedures of - no arguments (thunks). - - `dynamic-wind' calls THUNK1, THUNK2, and then THUNK3. The value - returned by THUNK2 is returned as the result of `dynamic-wind'. - THUNK3 is also called just before control leaves the dynamic - context of THUNK2 by calling a continuation created outside that - context. Furthermore, THUNK1 is called before reentering the - dynamic context of THUNK2 by calling a continuation created inside - that context. (Control is inside the context of THUNK2 if THUNK2 - is on the current return stack). - - *Warning:* There is no provision for dealing with errors or - interrupts. If an error or interrupt occurs while using - `dynamic-wind', the dynamic environment will be that in effect at - the time of the error or interrupt. - - -File: slib.info, Node: Eval, Next: Values, Prev: Dynamic-Wind, Up: Standards Support - -Eval ----- - - `(require 'eval)' - - - Function: eval expression environment-specifier - Evaluates EXPRESSION in the specified environment and returns its - value. EXPRESSION must be a valid Scheme expression represented - as data, and ENVIRONMENT-SPECIFIER must be a value returned by one - of the three procedures described below. Implementations may - extend `eval' to allow non-expression programs (definitions) as - the first argument and to allow other values as environments, with - the restriction that `eval' is not allowed to create new bindings - in the environments associated with `null-environment' or - `scheme-report-environment'. - - (eval '(* 7 3) (scheme-report-environment 5)) - => 21 - - (let ((f (eval '(lambda (f x) (f x x)) - (null-environment)))) - (f + 10)) - => 20 - - - Function: scheme-report-environment version - - Function: null-environment version - - Function: null-environment - VERSION must be an exact non-negative integer N corresponding to a - version of one of the Revised^N Reports on Scheme. - `Scheme-report-environment' returns a specifier for an environment - that contains the set of bindings specified in the corresponding - report that the implementation supports. `Null-environment' - returns a specifier for an environment that contains only the - (syntactic) bindings for all the syntactic keywords defined in the - given version of the report. - - Not all versions may be available in all implementations at all - times. However, an implementation that conforms to version N of - the Revised^N Reports on Scheme must accept version N. An error - is signalled if the specified version is not available. - - The effect of assigning (through the use of `eval') a variable - bound in a `scheme-report-environment' (for example `car') is - unspecified. Thus the environments specified by - `scheme-report-environment' may be immutable. - - - - Function: interaction-environment - This optional procedure returns a specifier for the environment - that contains implementation-defined bindings, typically a - superset of those listed in the report. The intent is that this - procedure will return the environment in which the implementation - would evaluate expressions dynamically typed by the user. - -Here are some more `eval' examples: - - (require 'eval) - => # - (define car 'volvo) - => # - car - => volvo - (eval 'car (interaction-environment)) - => volvo - (eval 'car (scheme-report-environment 5)) - => # - (eval '(eval 'car (interaction-environment)) - (scheme-report-environment 5)) - => volvo - (eval '(eval '(set! car 'buick) (interaction-environment)) - (scheme-report-environment 5)) - => # - car - => buick - (eval 'car (scheme-report-environment 5)) - => # - (eval '(eval 'car (interaction-environment)) - (scheme-report-environment 5)) - => buick - - -File: slib.info, Node: Values, Prev: Eval, Up: Standards Support - -Values ------- - - `(require 'values)' - - - Function: values obj ... - `values' takes any number of arguments, and passes (returns) them - to its continuation. - - - Function: call-with-values thunk proc - THUNK must be a procedure of no arguments, and PROC must be a - procedure. `call-with-values' calls THUNK with a continuation - that, when passed some values, calls PROC with those values as - arguments. - - Except for continuations created by the `call-with-values' - procedure, all continuations take exactly one value, as now; the - effect of passing no value or more than one value to continuations - that were not created by the `call-with-values' procedure is - unspecified. - - -File: slib.info, Node: Session Support, Next: Extra-SLIB Packages, Prev: Standards Support, Up: Other Packages - -Session Support -=============== - -* Menu: - -* Repl:: Macros at top-level -* Quick Print:: Loop-safe Output -* Debug:: To err is human ... -* Breakpoints:: Pause execution -* Trace:: 'trace -* System Interface:: 'system, 'getenv, and 'net-clients - - -File: slib.info, Node: Repl, Next: Quick Print, Prev: Session Support, Up: Session Support - -Repl ----- - - `(require 'repl)' - - Here is a read-eval-print-loop which, given an eval, evaluates forms. - - - Procedure: repl:top-level repl:eval - `read's, `repl:eval's and `write's expressions from - `(current-input-port)' to `(current-output-port)' until an - end-of-file is encountered. `load', `slib:eval', `slib:error', - and `repl:quit' dynamically bound during `repl:top-level'. - - - Procedure: repl:quit - Exits from the invocation of `repl:top-level'. - - The `repl:' procedures establish, as much as is possible to do -portably, a top level environment supporting macros. `repl:top-level' -uses `dynamic-wind' to catch error conditions and interrupts. If your -implementation supports this you are all set. - - Otherwise, if there is some way your implementation can catch error -conditions and interrupts, then have them call `slib:error'. It will -display its arguments and reenter `repl:top-level'. `slib:error' -dynamically bound by `repl:top-level'. - - To have your top level loop always use macros, add any interrupt -catching lines and the following lines to your Scheme init file: - (require 'macro) - (require 'repl) - (repl:top-level macro:eval) - - -File: slib.info, Node: Quick Print, Next: Debug, Prev: Repl, Up: Session Support - -Quick Print ------------ - - `(require 'qp)' - -When displaying error messages and warnings, it is paramount that the -output generated for circular lists and large data structures be -limited. This section supplies a procedure to do this. It could be -much improved. - - Notice that the neccessity for truncating output eliminates - Common-Lisp's *Note Format:: from consideration; even when - variables `*print-level*' and `*print-level*' are set, huge - strings and bit-vectors are _not_ limited. - - - Procedure: qp arg1 ... - - Procedure: qpn arg1 ... - - Procedure: qpr arg1 ... - `qp' writes its arguments, separated by spaces, to - `(current-output-port)'. `qp' compresses printing by substituting - `...' for substructure it does not have sufficient room to print. - `qpn' is like `qp' but outputs a newline before returning. `qpr' - is like `qpn' except that it returns its last argument. - - - Variable: *qp-width* - `*qp-width*' is the largest number of characters that `qp' should - use. - - -File: slib.info, Node: Debug, Next: Breakpoints, Prev: Quick Print, Up: Session Support - -Debug ------ - - `(require 'debug)' - -Requiring `debug' automatically requires `trace' and `break'. - -An application with its own datatypes may want to substitute its own -printer for `qp'. This example shows how to do this: - - (define qpn (lambda args) ...) - (provide 'qp) - (require 'debug) - - - Procedure: trace-all file ... - Traces (*note Trace::) all procedures `define'd at top-level in - `file' .... - - - Procedure: track-all file ... - Tracks (*note Trace::) all procedures `define'd at top-level in - `file' .... - - - Procedure: stack-all file ... - Stacks (*note Trace::) all procedures `define'd at top-level in - `file' .... - - - Procedure: break-all file ... - Breakpoints (*note Breakpoints::) all procedures `define'd at - top-level in `file' .... - - -File: slib.info, Node: Breakpoints, Next: Trace, Prev: Debug, Up: Session Support - -Breakpoints ------------ - - `(require 'break)' - - - Function: init-debug - If your Scheme implementation does not support `break' or `abort', - a message will appear when you `(require 'break)' or `(require - 'debug)' telling you to type `(init-debug)'. This is in order to - establish a top-level continuation. Typing `(init-debug)' at top - level sets up a continuation for `break'. - - - Function: breakpoint arg1 ... - Returns from the top level continuation and pushes the - continuation from which it was called on a continuation stack. - - - Function: continue - Pops the topmost continuation off of the continuation stack and - returns an unspecified value to it. - - - Function: continue arg1 ... - Pops the topmost continuation off of the continuation stack and - returns ARG1 ... to it. - - - Macro: break proc1 ... - Redefines the top-level named procedures given as arguments so that - `breakpoint' is called before calling PROC1 .... - - - Macro: break - With no arguments, makes sure that all the currently broken - identifiers are broken (even if those identifiers have been - redefined) and returns a list of the broken identifiers. - - - Macro: unbreak proc1 ... - Turns breakpoints off for its arguments. - - - Macro: unbreak - With no arguments, unbreaks all currently broken identifiers and - returns a list of these formerly broken identifiers. - - These are _procedures_ for breaking. If defmacros are not natively -supported by your implementation, these might be more convenient to use. - - - Function: breakf proc - - Function: breakf proc name - To break, type - (set! SYMBOL (breakf SYMBOL)) - - or - (set! SYMBOL (breakf SYMBOL 'SYMBOL)) - - or - (define SYMBOL (breakf FUNCTION)) - - or - (define SYMBOL (breakf FUNCTION 'SYMBOL)) - - - Function: unbreakf proc - To unbreak, type - (set! SYMBOL (unbreakf SYMBOL)) - - -File: slib.info, Node: Trace, Next: System Interface, Prev: Breakpoints, Up: Session Support - -Tracing -------- - - `(require 'trace)' - -This feature provides three ways to monitor procedure invocations: - -stack - Pushes the procedure-name when the procedure is called; pops when - it returns. - -track - Pushes the procedure-name and arguments when the procedure is - called; pops when it returns. - -trace - Pushes the procedure-name and prints `CALL PROCEDURE-NAME ARG1 - ...' when the procdure is called; pops and prints `RETN - PROCEDURE-NAME VALUE' when the procedure returns. - - - Variable: debug:max-count - If a traced procedure calls itself or untraced procedures which - call it, stack, track, and trace will limit the number of stack - pushes to DEBUG:MAX-COUNT. - - - Function: print-call-stack - - Function: print-call-stack port - Prints the call-stack to PORT or the current-error-port. - - - Macro: trace proc1 ... - Traces the top-level named procedures given as arguments. - - - Macro: trace - With no arguments, makes sure that all the currently traced - identifiers are traced (even if those identifiers have been - redefined) and returns a list of the traced identifiers. - - - Macro: track proc1 ... - Traces the top-level named procedures given as arguments. - - - Macro: track - With no arguments, makes sure that all the currently tracked - identifiers are tracked (even if those identifiers have been - redefined) and returns a list of the tracked identifiers. - - - Macro: stack proc1 ... - Traces the top-level named procedures given as arguments. - - - Macro: stack - With no arguments, makes sure that all the currently stacked - identifiers are stacked (even if those identifiers have been - redefined) and returns a list of the stacked identifiers. - - - Macro: untrace proc1 ... - Turns tracing, tracking, and off for its arguments. - - - Macro: untrace - With no arguments, untraces all currently traced identifiers and - returns a list of these formerly traced identifiers. - - - Macro: untrack proc1 ... - Turns tracing, tracking, and off for its arguments. - - - Macro: untrack - With no arguments, untracks all currently tracked identifiers and - returns a list of these formerly tracked identifiers. - - - Macro: unstack proc1 ... - Turns tracing, stacking, and off for its arguments. - - - Macro: unstack - With no arguments, unstacks all currently stacked identifiers and - returns a list of these formerly stacked identifiers. - - These are _procedures_ for tracing. If defmacros are not natively -supported by your implementation, these might be more convenient to use. - - - Function: tracef proc - - Function: tracef proc name - To trace, type - (set! SYMBOL (tracef SYMBOL)) - - or - (set! SYMBOL (tracef SYMBOL 'SYMBOL)) - - or - (define SYMBOL (tracef FUNCTION)) - - or - (define SYMBOL (tracef FUNCTION 'SYMBOL)) - - - Function: untracef proc - Removes tracing, tracking, or stacking for PROC. To untrace, type - (set! SYMBOL (untracef SYMBOL)) - - -File: slib.info, Node: System Interface, Prev: Trace, Up: Session Support - -System Interface ----------------- - -If `(provided? 'getenv)': - - - Function: getenv name - Looks up NAME, a string, in the program environment. If NAME is - found a string of its value is returned. Otherwise, `#f' is - returned. - -If `(provided? 'system)': - - - Function: system command-string - Executes the COMMAND-STRING on the computer and returns the - integer status code. - -If `system' is provided by the Scheme implementation, the "net-clients" -package provides interfaces to common network client programs like FTP, -mail, and Netscape. - - `(require 'net-clients)' - - - Function: call-with-tmpnam proc - - Function: call-with-tmpnam proc k - Calls PROC with K arguments, strings returned by successive calls - to `tmpnam'. If PROC returns, then any files named by the - arguments to PROC are deleted automatically and the value(s) - yielded by the PROC is(are) returned. K may be ommited, in which - case it defaults to `1'. - - - Function: user-email-address - `user-email-address' returns a string of the form - `username@hostname'. If this e-mail address cannot be obtained, - #f is returned. - - - Function: current-directory - `current-directory' returns a string containing the absolute file - name representing the current working directory. If this string - cannot be obtained, #f is returned. - - If `current-directory' cannot be supported by the platform, the - value of `current-directory' is #f. - - - Function: make-directory name - Creates a sub-directory NAME of the current-directory. If - successful, `make-directory' returns #t; otherwise #f. - - - Function: null-directory? file-name - Returns #t if changing directory to FILE-NAME makes the current - working directory the same as it is before changing directory; - otherwise returns #f. - - - Function: absolute-path? file-name - Returns #t if FILE-NAME is a fully specified pathname (does not - depend on the current working directory); otherwise returns #f. - - - Function: glob-pattern? str - Returns #t if the string STR contains characters used for - specifying glob patterns, namely `*', `?', or `['. - - - Function: parse-ftp-address uri | - Returns a list of the decoded FTP URI; or #f if indecipherable. | - FTP "Uniform Resource Locator", "ange-ftp", and "getit" formats - are handled. The returned list has four elements which are - strings or #f: - - 0. username - - 1. password - - 2. remote-site - - 3. remote-directory - - - Function: ftp-upload paths user password remote-site remote-dir - PASSWORD must be a non-empty string or #f. PATHS must be a - non-empty list of pathnames or Glob patterns (*note Filenames::) - matching files to transfer. - - `ftp-upload' puts the files specified by PATHS into the REMOTE-DIR - directory of FTP REMOTE-SITE using name USER with (optional) - PASSWORD. - - If PASSWORD is #f and USER is not `ftp' or `anonymous', then USER - is ignored; FTP takes the username and password from the `.netrc' - or equivalent file. - - - Function: path->uri path | - Returns a URI-string for PATH on the local host. | - - - Function: browse-url-netscape url - If a `netscape' browser is running, `browse-url-netscape' causes - the browser to display the page specified by string URL and - returns #t. - - If the browser is not running, `browse-url-netscape' runs - `netscape' with the argument URL. If the browser starts as a - background job, `browse-url-netscape' returns #t immediately; if - the browser starts as a foreground job, then `browse-url-netscape' - returns #t when the browser exits; otherwise it returns #f. - - -File: slib.info, Node: Extra-SLIB Packages, Prev: Session Support, Up: Other Packages - -Extra-SLIB Packages -=================== - - Several Scheme packages have been written using SLIB. There are -several reasons why a package might not be included in the SLIB -distribution: - * Because it requires special hardware or software which is not - universal. - - * Because it is large and of limited interest to most Scheme users. - - * Because it has copying terms different enough from the other SLIB - packages that its inclusion would cause confusion. - - * Because it is an application program, rather than a library module. - - * Because I have been too busy to integrate it. - - Once an optional package is installed (and an entry added to -`*catalog*', the `require' mechanism allows it to be called up and used -as easily as any other SLIB package. Some optional packages (for which -`*catalog*' already has entries) available from SLIB sites are: - -SLIB-PSD - is a portable debugger for Scheme (requires emacs editor). - - http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz - - swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.tar.gz - - ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz - - ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz - - - With PSD, you can run a Scheme program in an Emacs buffer, set - breakpoints, single step evaluation and access and modify the - program's variables. It works by instrumenting the original source - code, so it should run with any R4RS compliant Scheme. It has been - tested with SCM, Elk 1.5, and the sci interpreter in the Scheme->C - system, but should work with other Schemes with a minimal amount - of porting, if at all. Includes documentation and user's manual. - Written by Pertti Kellom\"aki, pk@cs.tut.fi. The Lisp Pointers - article describing PSD (Lisp Pointers VI(1):15-23, January-March - 1993) is available as - http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html - - -SCHELOG - is an embedding of Prolog in Scheme. - http://www.cs.rice.edu/CS/PLT/packages/schelog/ - - -JFILTER - is a Scheme program which converts text among the JIS, EUC, and - Shift-JIS Japanese character sets. - http://www.sci.toyama-u.ac.jp/~iwao/Scheme/Jfilter/index.html - - -File: slib.info, Node: About SLIB, Next: Index, Prev: Other Packages, Up: Top - -About SLIB -********** - -More people than I can name have contributed to SLIB. Thanks to all of -you! - - SLIB 2d1, released March 2001. | - Aubrey Jaffer - Hyperactive Software - The Maniac Inside! - - -* Menu: - -* Installation:: How to install SLIB on your system. -* Porting:: SLIB to new platforms. -* Coding Guidelines:: How to write modules for SLIB. -* Copyrights:: Intellectual propery issues. - - -File: slib.info, Node: Installation, Next: Porting, Prev: About SLIB, Up: About SLIB - -Installation -============ - - Check the manifest in `README' to find a configuration file for your -Scheme implementation. Initialization files for most IEEE P1178 -compliant Scheme Implementations are included with this distribution. - - If the Scheme implementation supports `getenv', then the value of the -shell environment variable SCHEME_LIBRARY_PATH will be used for -`(library-vicinity)' if it is defined. Currently, Chez, Elk, -MITScheme, scheme->c, VSCM, and SCM support `getenv'. Scheme48 -supports `getenv' but does not use it for determining -`library-vicinity'. (That is done from the Makefile.) - - You should check the definitions of `software-type', -`scheme-implementation-version', `implementation-vicinity', and -`library-vicinity' in the initialization file. There are comments in -the file for how to configure it. - - Once this is done you can modify the startup file for your Scheme -implementation to `load' this initialization file. SLIB is then -installed. - - Multiple implementations of Scheme can all use the same SLIB -directory. Simply configure each implementation's initialization file -as outlined above. - - - Implementation: SCM - The SCM implementation does not require any initialization file as - SLIB support is already built into SCM. See the documentation - with SCM for installation instructions. - - - Implementation: VSCM - From: Matthias Blume - 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 - Date: Mon, 2 Oct 2000 21:29:48 -0400 (EDT) - From: Shriram Krishnamurthi - - We distribute an SLIB init file for our system. If you have PLT - Scheme (our preferred name for the entire suite, which includes - DrScheme, MzScheme and other implementations) installed, you ought - to be able to run "help-desk", or run `drscheme' and choose Help - Desk from the Help menu; in Help Desk, type `slib'. This will give - instructions for how to load the SLIB init file. - - -File: slib.info, Node: Porting, Next: Coding Guidelines, Prev: Installation, Up: About SLIB - -Porting -======= - - If there is no initialization file for your Scheme implementation, you -will have to create one. Your Scheme implementation must be largely -compliant with `IEEE Std 1178-1990', `Revised^4 Report on the -Algorithmic Language Scheme', or `Revised^5 Report on the Algorithmic -Language Scheme' in order to support SLIB. (1) - - `Template.scm' is an example configuration file. The comments inside -will direct you on how to customize it to reflect your system. Give -your new initialization file the implementation's name with `.init' -appended. For instance, if you were porting `foo-scheme' then the -initialization file might be called `foo.init'. - - Your customized version should then be loaded as part of your scheme -implementation's initialization. It will load `require.scm' from the -library; this will allow the use of `provide', `provided?', and -`require' along with the "vicinity" functions (these functions are -documented in the section *Note Require::). The rest of the library -will then be accessible in a system independent fashion. - - Please mail new working configuration files to `jaffer @ ai.mit.edu' -so that they can be included in the SLIB distribution. - - ---------- Footnotes ---------- - - (1) If you are porting a `Revised^3 Report on the Algorithmic -Language Scheme' implementation, then you will need to finish writing -`sc4sc3.scm' and `load' it from your initialization file. - - -File: slib.info, Node: Coding Guidelines, Next: Copyrights, Prev: Porting, Up: About SLIB - -Coding Guidelines -================= - - All library packages are written in IEEE P1178 Scheme and assume that -a configuration file and `require.scm' package have already been -loaded. Other versions of Scheme can be supported in library packages -as well by using, for example, `(provided? 'rev3-report)' or `(require -'rev3-report)' (*note Require::). - - The module name and `:' should prefix each symbol defined in the -package. Definitions for external use should then be exported by having -`(define foo module-name:foo)'. - - Code submitted for inclusion in SLIB should not duplicate routines -already in SLIB files. Use `require' to force those library routines -to be used by your package. Care should be taken that there are no -circularities in the `require's and `load's between the library -packages. - - Documentation should be provided in Emacs Texinfo format if possible, -But documentation must be provided. - - Your package will be released sooner with SLIB if you send me a file -which tests your code. Please run this test _before_ you send me the -code! - -Modifications -------------- - - Please document your changes. A line or two for `ChangeLog' is -sufficient for simple fixes or extensions. Look at the format of -`ChangeLog' to see what information is desired. Please send me `diff' -files from the latest SLIB distribution (remember to send `diff's of -`slib.texi' and `ChangeLog'). This makes for less email traffic and -makes it easier for me to integrate when more than one person is -changing a file (this happens a lot with `slib.texi' and `*.init' -files). - - If someone else wrote a package you want to significantly modify, -please try to contact the author, who may be working on a new version. -This will insure against wasting effort on obsolete versions. - - Please _do not_ reformat the source code with your favorite -beautifier, make 10 fixes, and send me the resulting source code. I do -not have the time to fish through 10000 diffs to find your 10 real -fixes. - - -File: slib.info, Node: Copyrights, Prev: Coding Guidelines, Up: About SLIB - -Copyrights -========== - - This section has instructions for SLIB authors regarding copyrights. - - Each package in SLIB must either be in the public domain, or come -with a statement of terms permitting users to copy, redistribute and -modify it. The comments at the beginning of `require.scm' and -`macwork.scm' illustrate copyright and appropriate terms. - - If your code or changes amount to less than about 10 lines, you do not -need to add your copyright or send a disclaimer. - -Putting code into the Public Domain ------------------------------------ - - In order to put code in the public domain you should sign a copyright -disclaimer and send it to the SLIB maintainer. Contact jaffer @ -ai.mit.edu for the address to mail the disclaimer to. - - I, NAME, hereby affirm that I have placed the software package - NAME in the public domain. - - I affirm that I am the sole author and sole copyright holder for - the software package, that I have the right to place this software - package in the public domain, and that I will do nothing to - undermine this status in the future. - - SIGNATURE AND DATE - - This wording assumes that you are the sole author. If you are not the -sole author, the wording needs to be different. If you don't want to be -bothered with sending a letter every time you release or modify a -module, make your letter say that it also applies to your future -revisions of that module. - - Make sure no employer has any claim to the copyright on the work you -are submitting. If there is any doubt, create a copyright disclaimer -and have your employer sign it. Mail the signed disclaimer to the SLIB -maintainer. Contact jaffer @ ai.mit.edu for the address to mail the -disclaimer to. An example disclaimer follows. - -Explicit copying terms ----------------------- - -If you submit more than about 10 lines of code which you are not placing -into the Public Domain (by sending me a disclaimer) you need to: - - * Arrange that your name appears in a copyright line for the - appropriate year. Multiple copyright lines are acceptable. - - * With your copyright line, specify any terms you require to be - different from those already in the file. - - * Make sure no employer has any claim to the copyright on the work - you are submitting. If there is any doubt, create a copyright - disclaimer and have your employer sign it. Mail the signed - disclaim to the SLIB maintainer. Contact jaffer @ ai.mit.edu for - the address to mail the disclaimer to. - -Example: Company Copyright Disclaimer -------------------------------------- - - This disclaimer should be signed by a vice president or general -manager of the company. If you can't get at them, anyone else -authorized to license out software produced there will do. Here is a -sample wording: - - EMPLOYER Corporation hereby disclaims all copyright interest in - the program PROGRAM written by NAME. - - EMPLOYER Corporation affirms that it has no other intellectual - property interest that would undermine this release, and will do - nothing to undermine it in the future. - - SIGNATURE AND DATE, - NAME, TITLE, EMPLOYER Corporation - - -File: slib.info, Node: Index, Prev: About SLIB, Up: Top - -Procedure and Macro Index -************************* - - This is an alphabetical list of all the procedures and macros in SLIB. - -* Menu: - -* -: Multi-argument / and -. -* -1+: Rev2 Procedures. -* /: Multi-argument / and -. -* 1+: Rev2 Procedures. -* <=?: Rev2 Procedures. -* =?: Rev2 Procedures. -* >?: Rev2 Procedures. -* absolute-path?: System Interface. -* add-domain: Database Utilities. -* add-process!: Multi-Processing. -* add-setter: Setters. -* adjoin: Lists as sets. -* adjoin-parameters!: Parameter lists. -* alarm: Multi-Processing. -* alarm-interrupt: Multi-Processing. -* alist->wt-tree: Construction of Weight-Balanced Trees. -* alist-associator: Association Lists. -* alist-for-each: Association Lists. -* alist-inquirer: Association Lists. -* alist-map: Association Lists. -* alist-remover: Association Lists. -* and?: Non-List functions. -* any?: Collections. -* append!: Rev2 Procedures. -* apply: Multi-argument Apply. -* array-1d-ref: Arrays. -* array-1d-set!: Arrays. -* array-2d-ref: Arrays. -* array-2d-set!: Arrays. -* array-3d-ref: Arrays. -* array-3d-set!: Arrays. -* array-copy!: Array Mapping. -* array-dimensions: Arrays. -* array-for-each: Array Mapping. -* array-in-bounds?: Arrays. -* array-index-map!: Array Mapping. -* array-indexes: Array Mapping. -* array-map!: Array Mapping. -* array-rank: Arrays. -* array-ref: Arrays. -* array-set!: Arrays. -* array-shape: Arrays. -* array?: Arrays. -* asctime: Posix Time. -* ash: Bit-Twiddling. -* atom?: Non-List functions. -* batch:call-with-output-script: Batch. -* batch:command: Batch. -* batch:comment: Batch. -* batch:delete-file: Batch. -* batch:initialize!: Batch. -* batch:lines->file: Batch. -* batch:rename-file: Batch. -* batch:run-script: Batch. -* batch:try-chopped-command: Batch. -* batch:try-command: Batch. -* bit-extract: Bit-Twiddling. -* bit-field: Bit-Twiddling. -* bitwise-if: Bit-Twiddling. -* break: Breakpoints. -* break-all: Debug. -* breakf: Breakpoints. -* breakpoint: Breakpoints. -* browse: Database Browser. -* browse-url-netscape: System Interface. -* butlast: Lists as sequences. -* butnthcdr: Lists as sequences. -* byte-ref: Byte. -* byte-set!: Byte. -* bytes: Byte. -* bytes->list: Byte. -* bytes-length: Byte. -* call-with-dynamic-binding: Dynamic Data Type. -* call-with-input-string: String Ports. -* call-with-output-string: String Ports. -* call-with-tmpnam: System Interface. -* call-with-values: Values. -* capture-syntactic-environment: Syntactic Closures. -* cart-prod-tables: Relational Database Operations. -* catalog->html: HTML Tables. | -* cgi:serve-query: HTTP and CGI. -* chap:next-string: Chapter Ordering. -* chap:string<=?: Chapter Ordering. -* chap:string=?: Chapter Ordering. -* chap:string>?: Chapter Ordering. -* check-parameters: Parameter lists. -* close-base: Base Table. -* close-database: Relational Database Operations. -* close-table: Table Operations. -* coerce: Type Coercion. | -* collection?: Collections. -* combined-rulesets: Commutative Rings. -* command->p-specs: HTML. | -* command:make-editable-table: HTML Tables. | -* command:modify-table: HTML Tables. | -* continue: Breakpoints. -* copy-bit: Bit-Twiddling. -* copy-bit-field: Bit-Twiddling. -* copy-list: List construction. -* copy-random-state: Random Numbers. -* copy-tree: Tree Operations. -* create-database <1>: Database Utilities. -* create-database: Creating and Opening Relational Databases. -* create-report: Database Reports. -* create-table: Relational Database Operations. -* create-view: Relational Database Operations. -* cring:define-rule: Commutative Rings. -* ctime: Posix Time. -* current-directory: System Interface. -* current-error-port: Input/Output. -* current-input-port <1>: Byte. -* current-input-port: Ruleset Definition and Use. -* current-output-port: Byte. -* current-time: Time and Date. -* db->html-directory: HTML Tables. | -* db->html-files: HTML Tables. | -* db->netscape: HTML Tables. -* decode-universal-time: Common-Lisp Time. -* define-access-operation: Setters. -* define-operation: Yasos interface. -* define-predicate: Yasos interface. -* define-record: Structures. -* define-syntax: Macro by Example. -* define-tables: Database Utilities. -* defmacro: Defmacro. -* defmacro:eval: Defmacro. -* defmacro:expand*: Defmacro. -* defmacro:load: Defmacro. -* defmacro?: Defmacro. -* delete <1>: Destructive list operations. -* delete: Base Table. -* delete*: Base Table. -* delete-domain: Database Utilities. -* delete-file: Input/Output. -* delete-if: Destructive list operations. -* delete-if-not: Destructive list operations. -* delete-table: Relational Database Operations. -* dequeue!: Queues. -* determinant: Determinant. | -* difftime: Time and Date. -* display-file: Line I/O. -* do-elts: Collections. -* do-keys: Collections. -* domain-checker: Database Utilities. -* dynamic-ref: Dynamic Data Type. -* dynamic-set!: Dynamic Data Type. -* dynamic-wind: Dynamic-Wind. -* dynamic?: Dynamic Data Type. -* empty?: Collections. -* encode-universal-time: Common-Lisp Time. -* enquque!: Queues. -* equal?: Byte. -* eval: Eval. -* every: Lists as sets. -* every?: Collections. -* extended-euclid: Modular Arithmetic. -* factor: Prime Numbers. -* fft: Fast Fourier Transform. -* fft-1: Fast Fourier Transform. -* file-exists?: Input/Output. -* filename:match-ci??: Filenames. -* filename:match??: Filenames. -* filename:substitute-ci??: Filenames. -* filename:substitute??: Filenames. -* fill-empty-parameters: Parameter lists. -* find-if: Lists as sets. -* find-ratio: Rationalize. -* find-ratio-between: Rationalize. -* find-string-from-port?: String Search. -* fluid-let: Fluid-Let. -* for-each-elt: Collections. -* for-each-key <1>: Collections. -* for-each-key: Base Table. -* for-each-row: Table Operations. -* force-output: Input/Output. -* form:delimited: HTML. | -* form:element: HTML. | -* form:image: HTML. | -* form:reset: HTML. | -* form:submit: HTML. | -* format: Format Interface. -* fprintf: Standard Formatted Output. -* fscanf: Standard Formatted Input. -* ftp-upload: System Interface. -* generic-write: Generic-Write. -* gentemp: Defmacro. -* get: Table Operations. -* get*: Table Operations. -* get-decoded-time: Common-Lisp Time. -* get-method: Object. -* get-universal-time: Common-Lisp Time. -* getenv: System Interface. -* getopt: Getopt. -* getopt--: Getopt. -* getopt->arglist: Getopt Parameter lists. -* getopt->parameter-list: Getopt Parameter lists. -* glob-pattern?: System Interface. -* gmktime: Posix Time. -* gmtime: Posix Time. -* golden-section-search: Minimizing. -* gtime: Posix Time. -* has-duplicates?: Lists as sets. -* hash: Hashing. -* hash-associator: Hash Tables. -* hash-for-each: Hash Tables. -* hash-inquirer: Hash Tables. -* hash-map: Hash Tables. -* hash-remover: Hash Tables. -* hashq: Hashing. -* hashv: Hashing. -* heap-extract-max!: Priority Queues. -* heap-insert!: Priority Queues. -* heap-length: Priority Queues. -* home-vicinity: Vicinity. -* html:anchor: URI. | -* html:atval: HTML. -* html:base: URI. | -* html:body: HTML. -* html:buttons: HTML. | -* html:caption: HTML Tables. | -* html:checkbox: HTML. | -* html:comment: HTML. -* html:editable-row-converter: HTML Tables. | -* html:form: HTML. -* html:head: HTML. -* html:heading: HTML Tables. -* html:hidden: HTML. | -* html:href-heading: HTML Tables. -* html:http-equiv: HTML. | -* html:isindex: URI. | -* html:link: URI. | -* html:linked-row-converter: HTML Tables. | -* html:meta: HTML. | -* html:meta-refresh: HTML. | -* html:plain: HTML. -* html:pre: HTML. -* html:select: HTML. | -* html:table: HTML Tables. -* html:text: HTML. | -* html:text-area: HTML. | -* http:content: HTTP and CGI. -* http:error-page: HTTP and CGI. -* http:forwarding-page: HTTP and CGI. | -* http:header: HTTP and CGI. -* http:serve-query: HTTP and CGI. -* identifier=?: Syntactic Closures. -* identifier?: Syntactic Closures. -* identity: Legacy. -* implementation-vicinity: Vicinity. -* in-vicinity: Vicinity. -* init-debug: Breakpoints. -* integer-expt: Bit-Twiddling. -* integer-length: Bit-Twiddling. -* integer-sqrt: Root Finding. -* interaction-environment: Eval. -* intersection: Lists as sets. -* jacobi-symbol: Prime Numbers. -* kill-process!: Multi-Processing. -* kill-table: Base Table. -* laguerre:find-polynomial-root: Root Finding. -* laguerre:find-root: Root Finding. -* last: Lists as sequences. -* last-pair: Legacy. -* library-vicinity: Vicinity. -* list*: List construction. -* list->bytes: Byte. -* list->string: Rev4 Optional Procedures. -* list->vector: Rev4 Optional Procedures. -* list-of??: Lists as sets. | -* list-table-definition: Database Utilities. | -* list-tail: Rev4 Optional Procedures. -* load-option: Weight-Balanced Trees. -* localtime: Posix Time. -* logand: Bit-Twiddling. -* logbit?: Bit-Twiddling. -* logcount: Bit-Twiddling. -* logior: Bit-Twiddling. -* lognot: Bit-Twiddling. -* logtest: Bit-Twiddling. -* logxor: Bit-Twiddling. -* macro:eval <1>: Syntax-Case Macros. -* macro:eval <2>: Syntactic Closures. -* macro:eval <3>: Macros That Work. -* macro:eval: R4RS Macros. -* macro:expand <1>: Syntax-Case Macros. -* macro:expand <2>: Syntactic Closures. -* macro:expand <3>: Macros That Work. -* macro:expand: R4RS Macros. -* macro:load <1>: Syntax-Case Macros. -* macro:load <2>: Syntactic Closures. -* macro:load <3>: Macros That Work. -* macro:load: R4RS Macros. -* macroexpand: Defmacro. -* macroexpand-1: Defmacro. -* macwork:eval: Macros That Work. -* macwork:expand: Macros That Work. -* macwork:load: Macros That Work. -* make-: Structures. -* make-array: Arrays. -* make-base: Base Table. -* make-bytes: Byte. -* make-command-server: Database Utilities. -* make-directory: System Interface. -* make-dynamic: Dynamic Data Type. -* make-generic-method: Object. -* make-generic-predicate: Object. -* make-getter: Base Table. -* make-hash-table: Hash Tables. -* make-heap: Priority Queues. -* make-key->list: Base Table. -* make-key-extractor: Base Table. -* make-keyifier-1: Base Table. -* make-list: List construction. -* make-list-keyifier: Base Table. -* make-method!: Object. -* make-object: Object. -* make-parameter-list: Parameter lists. -* make-port-crc: Cyclic Checksum. -* make-predicate!: Object. -* make-promise: Promises. -* make-putter: Base Table. -* make-query-alist-command-server: HTTP and CGI. | -* make-queue: Queues. -* make-random-state: Random Numbers. -* make-record-type: Records. -* make-relational-system: Creating and Opening Relational Databases. -* make-ruleset: Commutative Rings. -* make-shared-array: Arrays. -* make-sierpinski-indexer: Hashing. -* make-syntactic-closure: Syntactic Closures. -* make-table: Base Table. -* make-uri: URI. | -* make-vicinity: Vicinity. -* make-wt-tree: Construction of Weight-Balanced Trees. -* make-wt-tree-type: Construction of Weight-Balanced Trees. -* map-elts: Collections. -* map-key: Base Table. -* map-keys: Collections. -* member-if: Lists as sets. -* merge: Sorting. -* merge!: Sorting. -* mktime: Posix Time. -* modular:: Modular Arithmetic. -* modular:*: Modular Arithmetic. -* modular:+: Modular Arithmetic. -* modular:expt: Modular Arithmetic. -* modular:invert: Modular Arithmetic. -* modular:invertable?: Modular Arithmetic. -* modular:negate: Modular Arithmetic. -* modular:normalize: Modular Arithmetic. -* modulus->integer: Modular Arithmetic. -* must-be-first: Batch. -* must-be-last: Batch. -* nconc: Destructive list operations. -* newton:find-root: Root Finding. -* newtown:find-integer-root: Root Finding. -* notany: Lists as sets. -* notevery: Lists as sets. -* nreverse: Destructive list operations. -* nthcdr: Lists as sequences. -* null-directory?: System Interface. -* null-environment: Eval. -* object: Yasos interface. -* object->limited-string: Object-To-String. -* object->string: Object-To-String. -* object-with-ancestors: Yasos interface. -* object?: Object. -* offset-time: Time and Date. -* open-base: Base Table. -* open-database <1>: Database Utilities. -* open-database: Creating and Opening Relational Databases. -* open-database!: Database Utilities. -* open-table <1>: Relational Database Operations. -* open-table: Base Table. -* operate-as: Yasos interface. -* or?: Non-List functions. -* ordered-for-each-key: Base Table. -* os->batch-dialect: Batch. -* output-port-height: Input/Output. -* output-port-width: Input/Output. -* parameter-list->arglist: Parameter lists. -* parameter-list-expand: Parameter lists. -* parameter-list-ref: Parameter lists. -* parse-ftp-address: System Interface. -* path->uri: System Interface. | -* plot!: Plotting. -* plot-function!: Plotting. -* pnm:array-write: Portable Image Files. -* pnm:image-file->array: Portable Image Files. -* pnm:type-dimensions: Portable Image Files. -* position: Lists as sequences. -* pprint-file: Pretty-Print. -* pprint-filter-file: Pretty-Print. -* prec:commentfix: Grammar Rule Definition. -* prec:define-grammar: Ruleset Definition and Use. -* prec:delim: Grammar Rule Definition. -* prec:infix: Grammar Rule Definition. -* prec:inmatchfix: Grammar Rule Definition. -* prec:make-led: Nud and Led Definition. -* prec:make-nud: Nud and Led Definition. -* prec:matchfix: Grammar Rule Definition. -* prec:nary: Grammar Rule Definition. -* prec:nofix: Grammar Rule Definition. -* prec:parse: Ruleset Definition and Use. -* prec:postfix: Grammar Rule Definition. -* prec:prefix: Grammar Rule Definition. -* prec:prestfix: Grammar Rule Definition. -* predicate->asso: Association Lists. -* predicate->hash: Hash Tables. -* predicate->hash-asso: Hash Tables. -* present?: Base Table. -* pretty-print: Pretty-Print. -* pretty-print->string: Pretty-Print. | -* prime?: Prime Numbers. -* primes<: Prime Numbers. -* primes>: Prime Numbers. -* print: Yasos interface. -* print-call-stack: Trace. -* printf: Standard Formatted Output. -* process:schedule!: Multi-Processing. -* program-vicinity: Vicinity. -* project-table: Relational Database Operations. -* provide <1>: Require. -* provide: Feature. -* provided? <1>: Require. -* provided?: Feature. -* qp: Quick Print. -* qpn: Quick Print. -* qpr: Quick Print. -* queue-empty?: Queues. -* queue-front: Queues. -* queue-pop!: Queues. -* queue-push!: Queues. -* queue-rear: Queues. -* queue?: Queues. -* random: Random Numbers. -* random:exp: Random Numbers. -* random:hollow-sphere!: Random Numbers. -* random:normal: Random Numbers. -* random:normal-vector!: Random Numbers. -* random:solid-sphere!: Random Numbers. -* random:uniform: Random Numbers. -* rationalize: Rationalize. -* read-byte: Byte. -* read-command: Command Line. -* read-line: Line I/O. -* read-line!: Line I/O. -* read-options-file: Command Line. -* record-accessor: Records. -* record-constructor: Records. -* record-modifier: Records. -* record-predicate: Records. -* reduce <1>: Lists as sequences. -* reduce: Collections. -* reduce-init: Lists as sequences. -* remove: Lists as sets. -* remove-duplicates: Lists as sets. -* remove-if: Lists as sets. -* remove-if-not: Lists as sets. -* remove-parameter: Parameter lists. -* remove-setter-for: Setters. -* repl:quit: Repl. -* repl:top-level: Repl. -* replace-suffix: Filenames. -* require <1>: Require. -* require <2>: Catalog Compilation. -* require: Requesting Features. -* require:feature->path <1>: Require. -* require:feature->path: Requesting Features. -* restrict-table: Relational Database Operations. -* row:delete: Table Operations. -* row:delete*: Table Operations. -* row:insert: Table Operations. -* row:insert*: Table Operations. -* row:remove: Table Operations. -* row:remove*: Table Operations. -* row:retrieve: Table Operations. -* row:retrieve*: Table Operations. -* row:update: Table Operations. -* row:update*: Table Operations. -* scanf: Standard Formatted Input. -* scanf-read-list: Standard Formatted Input. -* scheme-report-environment: Eval. -* schmooz: Schmooz. -* secant:find-bracketed-root: Root Finding. -* secant:find-root: Root Finding. -* seed->random-state: Random Numbers. -* set: Setters. -* set-: Structures. -* set-difference: Lists as sets. -* Setter: Collections. -* setter: Setters. -* si:conversion-factor: Metric Units. | -* singleton-wt-tree: Construction of Weight-Balanced Trees. -* size <1>: Collections. -* size: Yasos interface. -* slib:error: System. -* slib:eval: System. -* slib:eval-load: System. -* slib:exit: System. -* slib:load: System. -* slib:load-compiled: System. -* slib:load-source: System. -* slib:report: Configuration. -* slib:report-version: Configuration. -* slib:warn: System. -* software-type: Configuration. -* some: Lists as sets. -* sort: Sorting. -* sort!: Sorting. -* sorted?: Sorting. -* soundex: Hashing. -* sprintf: Standard Formatted Output. -* sscanf: Standard Formatted Input. -* stack: Trace. -* stack-all: Debug. -* string->list: Rev4 Optional Procedures. -* string-capitalize: String-Case. -* string-captialize!: String-Case. -* string-ci->symbol: String-Case. -* string-copy: Rev4 Optional Procedures. -* string-downcase: String-Case. -* string-downcase!: String-Case. -* string-fill!: Rev4 Optional Procedures. -* string-index: String Search. -* string-index-ci: String Search. -* string-join: Batch. -* string-null?: Rev2 Procedures. -* string-reverse-index: String Search. -* string-reverse-index-ci: String Search. -* string-subst: String Search. -* string-upcase: String-Case. -* string-upcase!: String-Case. -* sub-vicinity: Vicinity. -* subst: Tree Operations. -* substq: Tree Operations. -* substring-ci?: String Search. -* substring-fill!: Rev2 Procedures. -* substring-move-left!: Rev2 Procedures. -* substring-move-right!: Rev2 Procedures. -* substring?: String Search. -* substv: Tree Operations. -* supported-key-type?: Base Table. -* supported-type?: Base Table. -* symbol-append: String-Case. | -* symmetric:modulus: Modular Arithmetic. -* sync-base: Base Table. -* sync-database: Relational Database Operations. | -* syncase:eval: Syntax-Case Macros. -* syncase:expand: Syntax-Case Macros. -* syncase:load: Syntax-Case Macros. -* synclo:eval: Syntactic Closures. -* synclo:expand: Syntactic Closures. -* synclo:load: Syntactic Closures. -* syntax-rules: Macro by Example. -* system: System Interface. -* table->linked-html: HTML Tables. | -* table->linked-page: HTML Tables. | -* table-exists?: Relational Database Operations. -* table-name->filename: HTML Tables. -* TAG: Structures. -* tek40:draw: Tektronix Graphics Support. -* tek40:graphics: Tektronix Graphics Support. -* tek40:init: Tektronix Graphics Support. -* tek40:linetype: Tektronix Graphics Support. -* tek40:move: Tektronix Graphics Support. -* tek40:put-text: Tektronix Graphics Support. -* tek40:reset: Tektronix Graphics Support. -* tek40:text: Tektronix Graphics Support. -* tek41:draw: Tektronix Graphics Support. -* tek41:encode-int: Tektronix Graphics Support. -* tek41:encode-x-y: Tektronix Graphics Support. -* tek41:graphics: Tektronix Graphics Support. -* tek41:init: Tektronix Graphics Support. -* tek41:move: Tektronix Graphics Support. -* tek41:point: Tektronix Graphics Support. -* tek41:reset: Tektronix Graphics Support. -* time-zone: Time Zone. -* tmpnam: Input/Output. -* tok:char-group: Token definition. -* topological-sort: Topological Sort. -* trace: Trace. -* trace-all: Debug. -* tracef: Trace. -* track: Trace. -* track-all: Debug. -* transcript-off: Transcripts. -* transcript-on: Transcripts. -* transformer: Syntactic Closures. -* truncate-up-to: Batch. -* tsort: Topological Sort. -* two-arg:-: Multi-argument / and -. -* two-arg:/: Multi-argument / and -. -* two-arg:apply: Multi-argument Apply. -* type-of: Type Coercion. | -* tz:params: Time Zone. -* tzset: Time Zone. -* unbreak: Breakpoints. -* unbreakf: Breakpoints. -* union: Lists as sets. -* unmake-method!: Object. -* unstack: Trace. -* untrace: Trace. -* untracef: Trace. -* untrack: Trace. -* uri->tree: URI. | -* uric:decode: URI. | -* uric:encode: URI. | -* user-email-address: System Interface. -* user-vicinity: Vicinity. -* values: Values. -* variant-case: Structures. -* vector->list: Rev4 Optional Procedures. -* vector-fill!: Rev4 Optional Procedures. -* with-input-from-file: With-File. -* with-output-to-file: With-File. -* write-base: Base Table. -* write-byte: Byte. -* write-database: Relational Database Operations. -* write-line: Line I/O. -* wt-tree/add: Basic Operations on Weight-Balanced Trees. -* wt-tree/add!: Basic Operations on Weight-Balanced Trees. -* wt-tree/delete: Basic Operations on Weight-Balanced Trees. -* wt-tree/delete!: Basic Operations on Weight-Balanced Trees. -* wt-tree/delete-min: Indexing Operations on Weight-Balanced Trees. -* wt-tree/delete-min!: Indexing Operations on Weight-Balanced Trees. -* wt-tree/difference: Advanced Operations on Weight-Balanced Trees. -* wt-tree/empty?: Basic Operations on Weight-Balanced Trees. -* wt-tree/fold: Advanced Operations on Weight-Balanced Trees. -* wt-tree/for-each: Advanced Operations on Weight-Balanced Trees. -* wt-tree/index: Indexing Operations on Weight-Balanced Trees. -* wt-tree/index-datum: Indexing Operations on Weight-Balanced Trees. -* wt-tree/index-pair: Indexing Operations on Weight-Balanced Trees. -* wt-tree/intersection: Advanced Operations on Weight-Balanced Trees. -* wt-tree/lookup: Basic Operations on Weight-Balanced Trees. -* wt-tree/member?: Basic Operations on Weight-Balanced Trees. -* wt-tree/min: Indexing Operations on Weight-Balanced Trees. -* wt-tree/min-datum: Indexing Operations on Weight-Balanced Trees. -* wt-tree/min-pair: Indexing Operations on Weight-Balanced Trees. -* wt-tree/rank: Indexing Operations on Weight-Balanced Trees. -* wt-tree/set-equal?: Advanced Operations on Weight-Balanced Trees. -* wt-tree/size: Basic Operations on Weight-Balanced Trees. -* wt-tree/split<: Advanced Operations on Weight-Balanced Trees. -* wt-tree/split>: Advanced Operations on Weight-Balanced Trees. -* wt-tree/subset?: Advanced Operations on Weight-Balanced Trees. -* wt-tree/union: Advanced Operations on Weight-Balanced Trees. -* wt-tree?: Basic Operations on Weight-Balanced Trees. - -Variable Index -************** - - This is an alphabetical list of all the global variables in SLIB. - -* Menu: - -* *catalog*: Require. -* *features*: Require. -* *http:byline*: HTTP and CGI. -* *modules*: Require. -* *optarg*: Getopt. -* *optind*: Getopt. -* *qp-width*: Quick Print. -* *random-state*: Random Numbers. -* *ruleset*: Commutative Rings. -* *syn-defs*: Ruleset Definition and Use. -* *syn-ignore-whitespace*: Ruleset Definition and Use. -* *timezone*: Time Zone. -* batch:platform: Batch. -* catalog-id: Base Table. -* char-code-limit: Configuration. -* charplot:height: Plotting. -* charplot:width: Plotting. -* column-domains: Table Operations. -* column-foreigns: Table Operations. -* column-names: Table Operations. -* column-types: Table Operations. -* daylight?: Time Zone. -* debug:max-count: Trace. -* distribute*: Commutative Rings. -* distribute/: Commutative Rings. -* most-positive-fixnum: Configuration. -* nil: Legacy. -* number-wt-type: Construction of Weight-Balanced Trees. -* primary-limit: Table Operations. -* prime:prngs: Prime Numbers. -* prime:trials: Prime Numbers. -* slib:form-feed: Configuration. -* slib:tab: Configuration. -* stderr: Standard Formatted I/O. -* stdin: Standard Formatted I/O. -* stdout: Standard Formatted I/O. -* string-wt-type: Construction of Weight-Balanced Trees. -* t: Legacy. -* tok:decimal-digits: Token definition. -* tok:lower-case: Token definition. -* tok:upper-case: Token definition. -* tok:whitespaces: Token definition. -* tzname: Time Zone. - -Concept and Feature Index -************************* - -* Menu: - -* alist: Association Lists. -* alist-table <1>: Creating and Opening Relational Databases. -* alist-table: Base Table. -* ange-ftp: System Interface. -* array: Arrays. -* array-for-each: Array Mapping. -* attribute-value: HTML. -* balanced binary trees: Weight-Balanced Trees. -* base: URI. | -* batch: Batch. -* binary trees: Weight-Balanced Trees. -* binary trees, as discrete maps: Weight-Balanced Trees. -* binary trees, as sets: Weight-Balanced Trees. -* break: Breakpoints. -* byte: Byte. -* calendar time <1>: Posix Time. -* calendar time: Time and Date. -* Calendar-Time: Posix Time. -* caltime: Posix Time. -* careful: Commutative Rings. -* catalog: Requesting Features. -* Catalog File: Library Catalogs. -* chapter-order: Chapter Ordering. -* charplot: Plotting. -* coerce: Type Coercion. | -* collect: Collections. -* command line: Command Line. -* commentfix: Precedence Parsing Overview. -* common-list-functions <1>: Common List Functions. -* common-list-functions: Collections. -* commutative-ring: Commutative Rings. -* Coordinated Universal Time: Posix Time. -* database-utilities <1>: Database Utilities. -* database-utilities: Batch. -* debug <1>: Breakpoints. -* debug: Debug. -* defmacroexpand <1>: Pretty-Print. -* defmacroexpand: Defmacro. -* delim: Precedence Parsing Overview. -* discrete maps, using binary trees: Weight-Balanced Trees. -* DrScheme: Installation. -* dynamic: Dynamic Data Type. -* dynamic-wind: Dynamic-Wind. -* escaped: URI. | -* Euclidean Domain: Commutative Rings. -* factor: Prime Numbers. -* feature <1>: About this manual. -* feature <2>: Requesting Features. -* feature: Feature. -* fft: Fast Fourier Transform. -* fluid-let <1>: Database Utilities. -* fluid-let: Fluid-Let. -* form: HTML. -* format: Format. -* generic-write: Generic-Write. -* getit: System Interface. -* getopt <1>: Database Utilities. -* getopt: Getopt. -* glob <1>: Batch. -* glob: Filenames. -* hash: Hashing. -* hash-table: Hash Tables. -* HOME <1>: Vicinity. -* HOME: Library Catalogs. -* homecat: Catalog Compilation. -* implcat: Catalog Compilation. -* infix: Precedence Parsing Overview. -* inmatchfix: Precedence Parsing Overview. -* Left Denotation, led: Nud and Led Definition. -* line-i: Line I/O. -* logical: Bit-Twiddling. -* macro <1>: Repl. -* macro: R4RS Macros. -* macro-by-example: Macro by Example. -* macros-that-work: Macros That Work. -* make-crc: Cyclic Checksum. -* match: Base Table. -* match-keys <1>: Table Operations. -* match-keys: Base Table. -* matchfix: Precedence Parsing Overview. -* metric-units: Metric Units. | -* minimize: Minimizing. -* minimum field width (printf): Standard Formatted Output. -* mkimpcat.scm: Catalog Compilation. -* mklibcat.scm: Catalog Compilation. -* modular: Modular Arithmetic. -* multiarg-apply: Multi-argument Apply. -* mutliarg: Multi-argument / and -. -* MzScheme: Installation. -* nary: Precedence Parsing Overview. -* net-clients: System Interface. -* new-catalog: Catalog Compilation. | -* nofix: Precedence Parsing Overview. -* null: HTML Tables. | -* Null Denotation, nud: Nud and Led Definition. -* object: Object. -* object->string: Object-To-String. -* oop: Yasos. -* option, run-time-loadable: Weight-Balanced Trees. -* options file: Command Line. -* parameters <1>: Database Utilities. -* parameters <2>: Batch. -* parameters: Parameter lists. -* parse: Precedence Parsing. -* plain-text: HTML. -* PLT Scheme: Installation. -* posix-time: Posix Time. -* postfix: Precedence Parsing Overview. -* pprint-file: Pretty-Print. -* PRE: HTML. -* precedence: Precedence Parsing. -* precision (printf): Standard Formatted Output. -* prefix: Precedence Parsing Overview. -* prestfix: Precedence Parsing Overview. -* pretty-print: Pretty-Print. -* primes: Prime Numbers. -* printf: Standard Formatted Output. -* priority-queue: Priority Queues. -* PRNG: Random Numbers. -* process: Multi-Processing. -* promise: Promises. -* qp <1>: Quick Print. -* qp: Getopt. -* query-string: HTTP and CGI. -* queue: Queues. -* random: Random Numbers. -* rationalize: Rationalize. -* read-command: Command Line. -* record: Records. -* relational-database: Relational Database. -* repl <1>: Repl. -* repl: Syntax-Case Macros. -* reset: HTML. -* rev2-procedures: Rev2 Procedures. -* rev3-report: Coding Guidelines. -* rev4-optional-procedures: Rev4 Optional Procedures. -* ring, commutative: Commutative Rings. -* RNG: Random Numbers. -* root: Root Finding. -* run-time-loadable option: Weight-Balanced Trees. -* scanf: Standard Formatted Input. -* Scheme48: Installation. -* schmooz: Schmooz. -* SCM: Installation. -* Server-based Naming Authority: URI. | -* session: Feature. -* sets, using binary trees: Weight-Balanced Trees. -* sierpinski: Hashing. -* sitecat: Catalog Compilation. -* slibcat: Catalog Compilation. -* sort: Sorting. -* soundex: Hashing. -* stdio: Standard Formatted I/O. -* string-case: String-Case. -* string-port: String Ports. -* string-search: String Search. -* struct: Structures. -* syntactic-closures: Syntactic Closures. -* syntax-case: Syntax-Case Macros. -* time: Time and Date. -* time-zone: Time Zone. -* topological-sort: Topological Sort. -* trace: Trace. -* transcript: Transcripts. -* tree: Tree Operations. -* trees, balanced binary: Weight-Balanced Trees. -* tsort: Topological Sort. -* TZ-string: Time Zone. -* Uniform Resource Identifiers: URI. | -* Uniform Resource Locator: System Interface. -* Unique Factorization: Commutative Rings. -* unsafe: URI. | -* URI: HTTP and CGI. -* usercat: Catalog Compilation. -* UTC: Posix Time. -* values: Values. -* VSCM: Installation. -* weight-balanced binary trees: Weight-Balanced Trees. -* wild-card: Base Table. -* with-file: With-File. -* wt-tree: Weight-Balanced Trees. -* yasos: Yasos. - - - -Tag Table: -Node: Top1026 -Node: The Library System1740 -Node: Feature2054 -Node: Requesting Features3004 -Node: Library Catalogs4363 -Node: Catalog Compilation6815 -Node: Built-in Support9624 -Node: Require10255 -Node: Vicinity12747 -Node: Configuration15714 -Node: Input/Output18655 -Node: Legacy20254 -Node: System21096 -Node: About this manual23588 -Node: Scheme Syntax Extension Packages24145 -Node: Defmacro24830 -Node: R4RS Macros26781 -Node: Macro by Example28036 -Node: Macros That Work30913 -Node: Syntactic Closures36971 -Node: Syntax-Case Macros54405 -Node: Fluid-Let58531 -Node: Yasos59472 -Node: Yasos terms60265 -Node: Yasos interface61289 -Node: Setters63364 -Node: Yasos examples66005 -Node: Textual Conversion Packages68999 -Node: Precedence Parsing69697 -Node: Precedence Parsing Overview70360 -Ref: Precedence Parsing Overview-Footnote-172358 -Node: Ruleset Definition and Use72561 -Node: Token definition74942 -Node: Nud and Led Definition77211 -Node: Grammar Rule Definition79660 -Node: Format87234 -Node: Format Interface87482 -Node: Format Specification89219 -Node: Standard Formatted I/O99349 -Node: Standard Formatted Output99915 -Node: Standard Formatted Input109182 -Node: Programs and Arguments115842 -Node: Getopt116342 -Node: Command Line122184 -Node: Parameter lists125373 -Node: Getopt Parameter lists129358 -Node: Filenames133527 -Node: Batch136757 -Node: HTML144550 -Node: HTML Tables155838 -Node: HTTP and CGI166135 -Node: URI171452 -Node: Printing Scheme177162 -Node: Generic-Write177550 -Node: Object-To-String178953 -Node: Pretty-Print179357 -Node: Time and Date184343 -Node: Time Zone185370 -Node: Posix Time189931 -Node: Common-Lisp Time192067 -Node: Vector Graphics193646 -Node: Tektronix Graphics Support193835 -Node: Schmooz195209 -Node: Mathematical Packages199435 -Node: Bit-Twiddling200069 -Node: Modular Arithmetic204660 -Node: Prime Numbers206794 -Node: Random Numbers208477 -Node: Fast Fourier Transform213113 -Node: Cyclic Checksum214031 -Node: Plotting216292 -Node: Root Finding219151 -Node: Minimizing223138 -Ref: Minimizing-Footnote-1208597 -Node: Commutative Rings225178 -Node: Determinant236562 -Node: Database Packages237120 -Node: Base Table237384 -Node: Relational Database247798 -Node: Motivations248582 -Node: Creating and Opening Relational Databases253629 -Node: Relational Database Operations256061 -Node: Table Operations259258 -Node: Catalog Representation267136 -Node: Unresolved Issues270034 -Node: Database Utilities272985 -Node: Database Reports289598 -Node: Database Browser292352 -Node: Weight-Balanced Trees293413 -Node: Construction of Weight-Balanced Trees297284 -Node: Basic Operations on Weight-Balanced Trees300734 -Node: Advanced Operations on Weight-Balanced Trees303699 -Node: Indexing Operations on Weight-Balanced Trees309721 -Node: Other Packages313635 -Node: Data Structures314034 -Node: Arrays314790 -Node: Array Mapping317744 -Node: Association Lists319661 -Node: Byte321912 -Node: Portable Image Files324152 -Node: Collections325699 -Node: Dynamic Data Type331817 -Node: Hash Tables333078 -Node: Hashing335195 -Node: Object339989 -Node: Priority Queues348225 -Node: Queues349068 -Node: Records350194 -Node: Structures353705 -Node: Procedures355005 -Node: Common List Functions355852 -Node: List construction356276 -Node: Lists as sets357939 -Node: Lists as sequences365060 -Node: Destructive list operations370366 -Node: Non-List functions373029 -Node: Tree Operations374174 -Node: Type Coercion375796 -Node: Chapter Ordering377022 -Node: Sorting378719 -Node: Topological Sort384496 -Node: String-Case386183 -Node: String Ports387284 -Node: String Search388048 -Node: Line I/O390415 -Node: Multi-Processing392065 -Node: Metric Units393248 -Node: Standards Support408689 -Node: With-File409423 -Node: Transcripts409699 -Node: Rev2 Procedures410020 -Node: Rev4 Optional Procedures411727 -Node: Multi-argument / and -412297 -Node: Multi-argument Apply412948 -Node: Rationalize413434 -Node: Promises414876 -Node: Dynamic-Wind415293 -Node: Eval416547 -Node: Values419884 -Node: Session Support420671 -Node: Repl421139 -Node: Quick Print422422 -Node: Debug423535 -Node: Breakpoints424421 -Node: Trace426444 -Node: System Interface429555 -Node: Extra-SLIB Packages433443 -Node: About SLIB435743 -Node: Installation436407 -Node: Porting439635 -Ref: Porting-Footnote-1413781 -Node: Coding Guidelines441153 -Node: Copyrights443234 -Node: Index446519 - -End Tag Table diff --git a/module/slib/slib.spec b/module/slib/slib.spec deleted file mode 100644 index 67e1aa530..000000000 --- a/module/slib/slib.spec +++ /dev/null @@ -1,85 +0,0 @@ -%define name slib -%define version 2d1 -%define release 1 - -Name: %{name} -Release: %{release} -Version: %{version} -Packager: Radey Shouman - -Copyright: distributable, see individual files for copyright -Vendor: Aubrey Jaffer -Group: Development/Tools -Provides: slib -BuildArch: noarch - -Summary: platform independent library for scheme -Source: ftp://swissnet.ai.mit.edu/pub/scm/slib%{version}.zip -URL: http://swissnet.ai.mit.edu/~jaffer/SLIB.html -BuildRoot: %{_tmppath}/%{name}%{version} -Prefix: /usr/share - -%description -"SLIB" is a portable library for the programming language Scheme. -It provides a platform independent framework for using "packages" of -Scheme procedures and syntax. As distributed, SLIB contains useful -packages for all Scheme implementations. Its catalog can be -transparently extended to accomodate packages specific to a site, -implementation, user, or directory. - -%define __os_install_post /usr/lib/rpm/brp-compress - -%prep -%setup -n slib -c -T -cd .. -unzip $RPM_SOURCE_DIR/slib%{version}.zip - -%build -gzip -f slib.info - -%install -mkdir -p ${RPM_BUILD_ROOT}%{prefix}/slib -cp -r . ${RPM_BUILD_ROOT}%{prefix}/slib -mkdir -p ${RPM_BUILD_ROOT}/usr/info -cp slib.info.gz ${RPM_BUILD_ROOT}/usr/info - -%clean -rm -rf $RPM_BUILD_ROOT - -%post -/sbin/install-info /usr/info/slib.info.gz /usr/info/dir - -# This symlink is made as in the spec file of Robert J. Meier. -if [ -L /usr/share/guile/slib ]; then - rm /usr/share/guile/slib - ln -s %{prefix}/slib /usr/share/guile/slib -fi - -# This section should be extended to rebuild catalogs for as many -# implementations as possible. -if [ -x /usr/bin/guile ]; then - /usr/bin/guile -c "(use-modules (ice-9 slib)) (require 'new-catalog)" -fi -if [ -x /usr/bin/scm ]; then - /usr/bin/scm -c "(require 'new-catalog)" -fi - -%files -%defattr(-, root, root) -%dir %{prefix}/slib -%{prefix}/slib/*.scm -%{prefix}/slib/*.init -/usr/info/slib.info.gz -# The Makefile is included as it is useful for building documentation. -%{prefix}/slib/Makefile -%doc ANNOUNCE ChangeLog FAQ README - -%changelog -* Wed Mar 14 2001 Radey Shouman -- Adapted from the spec file of R. J. Meier. - -* Mon Jul 12 2000 Dr. Robert J. Meier 0.9.4-1suse -- Packaged for SuSE 6.3 - -* Sun May 30 2000 Aubrey Jaffer -- Updated content diff --git a/module/slib/slib.texi b/module/slib/slib.texi deleted file mode 100644 index 5194f47e5..000000000 --- a/module/slib/slib.texi +++ /dev/null @@ -1,11142 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c %**start of header -@setfilename slib.info -@settitle SLIB -@include version.txi -@setchapternewpage on -@c Choices for setchapternewpage are {on,off,odd}. -@paragraphindent 2 -@defcodeindex ft -@syncodeindex ft cp -@syncodeindex tp cp -@c %**end of header - -@dircategory The Algorithmic Language Scheme -@direntry -* SLIB: (slib). Scheme Library -@end direntry - -@iftex -@finalout -@c DL: lose the egregious vertical whitespace, esp. around examples -@c but paras in @defun-like things don't have parindent -@parskip 4pt plus 1pt -@end iftex - -@ifinfo -This file documents SLIB, the portable Scheme library. - -Copyright (C) 1993 Todd R. Eigenschink@* -Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000 Aubrey Jaffer - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that this permission notice may be stated in a translation approved -by the author. -@end ifinfo - -@node Top, The Library System, (dir), (dir) - -@titlepage -@title SLIB -@subtitle The Portable Scheme Library -@subtitle Version @value{SLIBVERSION} -@author by Aubrey Jaffer -@page - -@noindent -@dfn{SLIB} is a portable library for the programming language -@dfn{Scheme}. It provides a platform independent framework for using -@dfn{packages} of Scheme procedures and syntax. As distributed, SLIB -contains useful packages for all Scheme implementations. Its catalog -can be transparently extended to accomodate packages specific to a site, -implementation, user, or directory. - -@noindent -More people than I can name have contributed to SLIB. Thanks to all of -you! -@sp 1 -@quotation -SLIB @value{SLIBVERSION}, released @value{SLIBDATE}.@* -Aubrey Jaffer @* -@ifset html - -@end ifset -@url{http://swissnet.ai.mit.edu/~jaffer/SLIB.html} -@ifset html - -@end ifset -@end quotation - -@ifclear html -@vskip 0pt plus 1filll -Copyright @copyright{} 1993 Todd R. Eigenschink@* -Copyright @copyright{} 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000 Aubrey Jaffer - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that this permission notice may be stated in a translation approved -by the author. -@end ifclear -@end titlepage - -@ifinfo -@noindent -@dfn{SLIB} is a portable library for the programming language -@dfn{Scheme}. It provides a platform independent framework for using -@dfn{packages} of Scheme procedures and syntax. As distributed, SLIB -contains useful packages for all Scheme implementations. Its catalog -can be transparently extended to accomodate packages specific to a site, -implementation, user, or directory. -@end ifinfo - -@menu -* The Library System:: How to use and customize. -* Scheme Syntax Extension Packages:: -* Textual Conversion Packages:: -* Mathematical Packages:: -* Database Packages:: -* Other Packages:: -* About SLIB:: Install, etc. -* Index:: -@end menu - -@node The Library System, Scheme Syntax Extension Packages, Top, Top -@chapter The Library System - -@menu -* Feature:: SLIB names. -* Requesting Features:: -* Library Catalogs:: -* Catalog Compilation:: -* Built-in Support:: -* About this manual:: -@end menu - - -@node Feature, Requesting Features, The Library System, The Library System -@section Feature - -@noindent -@cindex feature -SLIB denotes @dfn{features} by symbols. SLIB maintains a list of -features supported by the Scheme @dfn{session}. The set of features -@cindex session -provided by a session may change over time. Some features are -properties of the Scheme implementation being used. The following -features detail what sort of numbers are available from an -implementation. - -@itemize @bullet -@item -'inexact -@item -'rational -@item -'real -@item -'complex -@item -'bignum -@end itemize - -@noindent -Other features correspond to the presence of sets of Scheme procedures -or syntax (macros). - -@defun provided? feature -Returns @code{#t} if @var{feature} is supported by the current Scheme -session. -@end defun - -@deffn Procedure provide feature -Informs SLIB that @var{feature} is supported. Henceforth -@code{(provided? @var{feature})} will return @code{#t}. -@end deffn - -@example -(provided? 'foo) @result{} #f -(provide 'foo) -(provided? 'foo) @result{} #t -@end example - - -@node Requesting Features, Library Catalogs, Feature, The Library System -@section Requesting Features - -@noindent -@cindex catalog -SLIB creates and maintains a @dfn{catalog} mapping features to locations -of files introducing procedures and syntax denoted by those features. - -@noindent -At the beginning of each section of this manual, there is a line like -@code{(require '@var{feature})}. -@ftindex feature -The Scheme files comprising SLIB are cataloged so that these feature -names map to the corresponding files. - -@noindent -SLIB provides a form, @code{require}, which loads the files providing -the requested feature. - -@deffn Procedure require feature -@itemize @bullet -@item -If @code{(provided? @var{feature})} is true, -then @code{require} just returns an unspecified value. -@item -Otherwise, if @var{feature} is found in the catalog, then the -corresponding files will be loaded and an unspecified value returned. - -Subsequently @code{(provided? @var{feature})} will return @code{#t}. -@item -Otherwise (@var{feature} not found in the catalog), an error is -signaled. -@end itemize -@end deffn - -@noindent -The catalog can also be queried using @code{require:feature->path}. - -@defun require:feature->path feature -@itemize @bullet -@item -If @var{feature} is already provided, then returns @code{#t}. -@item -Otherwise, if @var{feature} is in the catalog, the path or list of paths -associated with @var{feature} is returned. -@item -Otherwise, returns @code{#f}. -@end itemize -@end defun - - -@node Library Catalogs, Catalog Compilation, Requesting Features, The Library System -@section Library Catalogs - -@noindent -At the start of a session no catalog is present, but is created with the -first catalog inquiry (such as @code{(require 'random)}). Several -sources of catalog information are combined to produce the catalog: - -@itemize @bullet -@item -standard SLIB packages. -@item -additional packages of interest to this site. -@item -packages specifically for the variety of Scheme which this -session is running. -@item -packages this user wants to always have available. This catalog is the -file @file{homecat} in the user's @dfn{HOME} directory. -@cindex HOME -@item -packages germane to working in this (current working) directory. This -catalog is the file @file{usercat} in the directory to which it applies. -One would typically @code{cd} to this directory before starting the -Scheme session. -@end itemize - -@noindent -Catalog files consist of one or more @dfn{association list}s. -@cindex Catalog File -In the circumstance where a feature symbol appears in more than one -list, the latter list's association is retrieved. Here are the -supported formats for elements of catalog lists: - -@table @code -@item (@var{feature} . @i{}) -Redirects to the feature named @i{}. -@item (@var{feature} . "@i{}") -Loads file @i{}. -@item (@var{feature} source "@i{"}) -@code{slib:load}s the Scheme source file @i{}. -@item (@var{feature} compiled "@i{"} @dots{}) -@code{slib:load-compiled}s the files @i{} @dots{}. -@end table - -@noindent -The various macro styles first @code{require} the named macro package, -then just load @i{} or load-and-macro-expand @i{} as -appropriate for the implementation. - -@table @code -@item (@var{feature} defmacro "@i{"}) -@code{defmacro:load}s the Scheme source file @i{}. -@item (@var{feature} macro-by-example "@i{"}) -@code{defmacro:load}s the Scheme source file @i{}. -@end table - -@table @code -@item (@var{feature} macro "@i{"}) -@code{macro:load}s the Scheme source file @i{}. -@item (@var{feature} macros-that-work "@i{"}) -@code{macro:load}s the Scheme source file @i{}. -@item (@var{feature} syntax-case "@i{"}) -@code{macro:load}s the Scheme source file @i{}. -@item (@var{feature} syntactic-closures "@i{"}) -@code{macro:load}s the Scheme source file @i{}. -@end table - -@noindent -Here is an example of a @file{usercat} catalog. A Program in this -directory can invoke the @samp{run} feature with @code{(require 'run)}. - -@example -;;; "usercat": SLIB catalog additions for SIMSYNCH. -*-scheme-*- - -( - (simsynch . "../synch/simsynch.scm") - (run . "../synch/run.scm") - (schlep . "schlep.scm") -) -@end example - - -@node Catalog Compilation, Built-in Support, Library Catalogs, The Library System -@section Catalog Compilation - - -@noindent -SLIB combines the catalog information which doesn't vary per user into -the file @file{slibcat} in the implementation-vicinity. Therefore -@file{slibcat} needs change only when new software is installed or -compiled. Because the actual pathnames of files can differ from -installation to installation, SLIB builds a separate catalog for each -implementation it is used with. - -@noindent -The definition of @code{*SLIB-VERSION*} in SLIB file @file{require.scm} -is checked against the catalog association of @code{*SLIB-VERSION*} to -ascertain when versions have changed. I recommend that the definition -of @code{*SLIB-VERSION*} be changed whenever the library is changed. If -multiple implementations of Scheme use SLIB, remember that recompiling -one @file{slibcat} will fix only that implementation's catalog. - -@noindent -The compilation scripts of Scheme implementations which work with SLIB -can automatically trigger catalog compilation by deleting -@file{slibcat} or by invoking a special form of @code{require}: - -@deffn Procedure require @r{'new-catalog} -@cindex new-catalog -This will load @file{mklibcat}, which compiles and writes a new -@file{slibcat}. -@end deffn - -@noindent -Another special form of @code{require} erases SLIB's catalog, forcing it -to be reloaded the next time the catalog is queried. - -@deffn Procedure require @r{#f} -Removes SLIB's catalog information. This should be done before saving -an executable image so that, when restored, its catalog will be loaded -afresh. -@end deffn - -@noindent -Each file in the table below is descibed in terms of its -file-system independent @dfn{vicinity} (@pxref{Vicinity}). The entries -of a catalog in the table override those of catalogs above it in the -table. - -@table @asis - -@item @code{implementation-vicinity} @file{slibcat} -@cindex slibcat -This file contains the associations for the packages comprising SLIB, -the @file{implcat} and the @file{sitecat}s. The associations in the -other catalogs override those of the standard catalog. - -@item @code{library-vicinity} @file{mklibcat.scm} -@cindex mklibcat.scm -creates @file{slibcat}. - -@item @code{library-vicinity} @file{sitecat} -@cindex sitecat -This file contains the associations specific to an SLIB installation. - -@item @code{implementation-vicinity} @file{implcat} -@cindex implcat -This file contains the associations specific to an implementation of -Scheme. Different implementations of Scheme should have different -@code{implementation-vicinity}. - -@item @code{implementation-vicinity} @file{mkimpcat.scm} -@cindex mkimpcat.scm -if present, creates @file{implcat}. - -@item @code{implementation-vicinity} @file{sitecat} -@cindex sitecat -This file contains the associations specific to a Scheme implementation -installation. - -@item @code{home-vicinity} @file{homecat} -@cindex homecat -This file contains the associations specific to an SLIB user. - -@item @code{user-vicinity} @file{usercat} -@cindex usercat -This file contains associations effecting only those sessions whose -@dfn{working directory} is @code{user-vicinity}. - -@end table - -@node Built-in Support, About this manual, Catalog Compilation, The Library System -@section Built-in Support - -@noindent -The procedures described in these sections are supported by all -implementations as part of the @samp{*.init} files or by -@file{require.scm}. - -@menu -* Require:: Module Management -* Vicinity:: Pathname Management -* Configuration:: Characteristics of Scheme Implementation -* Input/Output:: Things not provided by the Scheme specs. -* Legacy:: -* System:: LOADing, EVALing, ERRORing, and EXITing -@end menu - - -@node Require, Vicinity, Built-in Support, Built-in Support -@subsection Require - -@defvar *features* -Is a list of symbols denoting features supported in this implementation. -@var{*features*} can grow as modules are @code{require}d. -@var{*features*} must be defined by all implementations -(@pxref{Porting}). - -Here are features which SLIB (@file{require.scm}) adds to -@var{*features*} when appropriate. - -@itemize @bullet -@item -'inexact -@item -'rational -@item -'real -@item -'complex -@item -'bignum -@end itemize - -For each item, @code{(provided? '@var{feature})} will return @code{#t} -if that feature is available, and @code{#f} if not. -@end defvar - -@defvar *modules* -Is a list of pathnames denoting files which have been loaded. -@end defvar - -@defvar *catalog* -Is an association list of features (symbols) and pathnames which will -supply those features. The pathname can be either a string or a pair. -If pathname is a pair then the first element should be a macro feature -symbol, @code{source}, or @code{compiled}. The cdr of the pathname -should be either a string or a list. -@end defvar - -@noindent -In the following functions if the argument @var{feature} is not a symbol -it is assumed to be a pathname. - -@defun provided? feature -Returns @code{#t} if @var{feature} is a member of @code{*features*} or -@code{*modules*} or if @var{feature} is supported by a file already -loaded and @code{#f} otherwise. -@end defun - -@deffn Procedure require feature -@var{feature} is a symbol. If @code{(provided? @var{feature})} is true -@code{require} returns. Otherwise, if @code{(assq @var{feature} -*catalog*)} is not @code{#f}, the associated files will be loaded and -@code{(provided? @var{feature})} will henceforth return @code{#t}. An -unspecified value is returned. If @var{feature} is not found in -@code{*catalog*}, then an error is signaled. - -@deffnx Procedure require pathname -@var{pathname} is a string. If @var{pathname} has not already been -given as an argument to @code{require}, @var{pathname} is loaded. An -unspecified value is returned. -@end deffn - -@deffn Procedure provide feature -Assures that @var{feature} is contained in @code{*features*} if -@var{feature} is a symbol and @code{*modules*} otherwise. -@end deffn - -@defun require:feature->path feature -Returns @code{#t} if @var{feature} is a member of @code{*features*} or -@code{*modules*} or if @var{feature} is supported by a file already -loaded. Returns a path if one was found in @code{*catalog*} under the -feature name, and @code{#f} otherwise. The path can either be a string -suitable as an argument to load or a pair as described above for -*catalog*. -@end defun - - - - -@node Vicinity, Configuration, Require, Built-in Support -@subsection Vicinity - -@noindent -A vicinity is a descriptor for a place in the file system. Vicinities -hide from the programmer the concepts of host, volume, directory, and -version. Vicinities express only the concept of a file environment -where a file name can be resolved to a file in a system independent -manner. Vicinities can even be used on @dfn{flat} file systems (which -have no directory structure) by having the vicinity express constraints -on the file name. On most systems a vicinity would be a string. All of -these procedures are file system dependent. - -@noindent -These procedures are provided by all implementations. - -@defun make-vicinity path -Returns the vicinity of @var{path} for use by @code{in-vicinity}. -@end defun - -@defun program-vicinity -Returns the vicinity of the currently loading Scheme code. For an -interpreter this would be the directory containing source code. For a -compiled system (with multiple files) this would be the directory where -the object or executable files are. If no file is currently loading it -the result is undefined. @strong{Warning:} @code{program-vicinity} can -return incorrect values if your program escapes back into a -@code{load}. -@end defun - -@defun library-vicinity -Returns the vicinity of the shared Scheme library. -@end defun - -@defun implementation-vicinity -Returns the vicinity of the underlying Scheme implementation. This -vicinity will likely contain startup code and messages and a compiler. -@end defun - -@defun user-vicinity -Returns the vicinity of the current directory of the user. On most -systems this is @file{""} (the empty string). -@end defun - -@defun home-vicinity -Returns the vicinity of the user's @dfn{HOME} directory, the directory -@cindex HOME -which typically contains files which customize a computer environment -for a user. If scheme is running without a user (eg. a daemon) or if -this concept is meaningless for the platform, then @code{home-vicinity} -returns @code{#f}. -@end defun - -@c @defun scheme-file-suffix -@c Returns the default filename suffix for scheme source files. On most -@c systems this is @samp{.scm}. -@c @end defun - -@defun in-vicinity vicinity filename -Returns a filename suitable for use by @code{slib:load}, -@code{slib:load-source}, @code{slib:load-compiled}, -@code{open-input-file}, @code{open-output-file}, etc. The returned -filename is @var{filename} in @var{vicinity}. @code{in-vicinity} should -allow @var{filename} to override @var{vicinity} when @var{filename} is -an absolute pathname and @var{vicinity} is equal to the value of -@code{(user-vicinity)}. The behavior of @code{in-vicinity} when -@var{filename} is absolute and @var{vicinity} is not equal to the value -of @code{(user-vicinity)} is unspecified. For most systems -@code{in-vicinity} can be @code{string-append}. -@end defun - -@defun sub-vicinity vicinity name -Returns the vicinity of @var{vicinity} restricted to @var{name}. This -is used for large systems where names of files in subsystems could -conflict. On systems with directory structure @code{sub-vicinity} will -return a pathname of the subdirectory @var{name} of -@var{vicinity}. -@end defun - - - -@node Configuration, Input/Output, Vicinity, Built-in Support -@subsection Configuration - -@noindent -These constants and procedures describe characteristics of the Scheme -and underlying operating system. They are provided by all -implementations. - -@defvr Constant char-code-limit -An integer 1 larger that the largest value which can be returned by -@code{char->integer}. -@end defvr - -@defvr Constant most-positive-fixnum -In implementations which support integers of practically unlimited size, -@var{most-positive-fixnum} is a large exact integer within the range of -exact integers that may result from computing the length of a list, -vector, or string. - -In implementations which do not support integers of practically -unlimited size, @var{most-positive-fixnum} is the largest exact integer -that may result from computing the length of a list, vector, or string. -@end defvr - -@defvr Constant slib:tab -The tab character. -@end defvr - -@defvr Constant slib:form-feed -The form-feed character. -@end defvr - -@defun software-type -Returns a symbol denoting the generic operating system type. For -instance, @code{unix}, @code{vms}, @code{macos}, @code{amiga}, or -@code{ms-dos}. -@end defun - -@defun slib:report-version -Displays the versions of SLIB and the underlying Scheme implementation -and the name of the operating system. An unspecified value is returned. - -@example -(slib:report-version) @result{} slib "@value{SLIBVERSION}" on scm "5b1" on unix -@end example -@end defun - -@defun slib:report -Displays the information of @code{(slib:report-version)} followed by -almost all the information neccessary for submitting a problem report. -An unspecified value is returned. - -@defunx slib:report #t -provides a more verbose listing. - -@defunx slib:report filename -Writes the report to file @file{filename}. - -@example -(slib:report) -@result{} -slib "@value{SLIBVERSION}" on scm "5b1" on unix -(implementation-vicinity) is "/home/jaffer/scm/" -(library-vicinity) is "/home/jaffer/slib/" -(scheme-file-suffix) is ".scm" -loaded *features* : - trace alist qp sort - common-list-functions macro values getopt - compiled -implementation *features* : - bignum complex real rational - inexact vicinity ed getenv - tmpnam abort transcript with-file - ieee-p1178 rev4-report rev4-optional-procedures hash - object-hash delay eval dynamic-wind - multiarg-apply multiarg/and- logical defmacro - string-port source current-time record - rev3-procedures rev2-procedures sun-dl string-case - array dump char-ready? full-continuation - system -implementation *catalog* : - (i/o-extensions compiled "/home/jaffer/scm/ioext.so") - ... -@end example -@end defun - -@node Input/Output, Legacy, Configuration, Built-in Support -@subsection Input/Output - -@noindent -These procedures are provided by all implementations. - -@deffn Procedure file-exists? filename -Returns @code{#t} if the specified file exists. Otherwise, returns -@code{#f}. If the underlying implementation does not support this -feature then @code{#f} is always returned. -@end deffn - -@deffn Procedure delete-file filename -Deletes the file specified by @var{filename}. If @var{filename} can not -be deleted, @code{#f} is returned. Otherwise, @code{#t} is -returned. -@end deffn - -@deffn Procedure tmpnam -Returns a pathname for a file which will likely not be used by any other -process. Successive calls to @code{(tmpnam)} will return different -pathnames. -@end deffn - -@deffn Procedure current-error-port -Returns the current port to which diagnostic and error output is -directed. -@end deffn - -@deffn Procedure force-output -@deffnx Procedure force-output port -Forces any pending output on @var{port} to be delivered to the output -device and returns an unspecified value. The @var{port} argument may be -omitted, in which case it defaults to the value returned by -@code{(current-output-port)}. -@end deffn - -@deffn Procedure output-port-width -@deffnx Procedure output-port-width port - -Returns the width of @var{port}, which defaults to -@code{(current-output-port)} if absent. If the width cannot be -determined 79 is returned. -@end deffn - -@deffn Procedure output-port-height -@deffnx Procedure output-port-height port - -Returns the height of @var{port}, which defaults to -@code{(current-output-port)} if absent. If the height cannot be -determined 24 is returned. -@end deffn - -@node Legacy, System, Input/Output, Built-in Support -@subsection Legacy - -These procedures are provided by all implementations. - -@defun identity x -@var{identity} returns its argument. - -Example: -@lisp -(identity 3) - @result{} 3 -(identity '(foo bar)) - @result{} (foo bar) -(map identity @var{lst}) - @equiv{} (copy-list @var{lst}) -@end lisp -@end defun - -@noindent -The following procedures were present in Scheme until R4RS -(@pxref{Notes, , Language changes ,r4rs, Revised(4) Scheme}). -They are provided by all SLIB implementations. - -@defvr Constant t -Derfined as @code{#t}. -@end defvr - -@defvr Constant nil -Defined as @code{#f}. -@end defvr - -@defun last-pair l -Returns the last pair in the list @var{l}. Example: -@lisp -(last-pair (cons 1 2)) - @result{} (1 . 2) -(last-pair '(1 2)) - @result{} (2) - @equiv{} (cons 2 '()) -@end lisp -@end defun - -@node System, , Legacy, Built-in Support -@subsection System - -@noindent -These procedures are provided by all implementations. - -@deffn Procedure slib:load-source name -Loads a file of Scheme source code from @var{name} with the default -filename extension used in SLIB. For instance if the filename extension -used in SLIB is @file{.scm} then @code{(slib:load-source "foo")} will -load from file @file{foo.scm}. -@end deffn - -@deffn Procedure slib:load-compiled name -On implementations which support separtely loadable compiled modules, -loads a file of compiled code from @var{name} with the implementation's -filename extension for compiled code appended. -@end deffn - -@deffn Procedure slib:load name -Loads a file of Scheme source or compiled code from @var{name} with the -appropriate suffixes appended. If both source and compiled code are -present with the appropriate names then the implementation will load -just one. It is up to the implementation to choose which one will be -loaded. - -If an implementation does not support compiled code then -@code{slib:load} will be identical to @code{slib:load-source}. -@end deffn - -@deffn Procedure slib:eval obj -@code{eval} returns the value of @var{obj} evaluated in the current top -level environment. @ref{Eval} provides a more general evaluation -facility. -@end deffn - -@deffn Procedure slib:eval-load filename eval -@var{filename} should be a string. If filename names an existing file, -the Scheme source code expressions and definitions are read from the -file and @var{eval} called with them sequentially. The -@code{slib:eval-load} procedure does not affect the values returned by -@code{current-input-port} and @code{current-output-port}. -@end deffn - -@deffn Procedure slib:warn arg1 arg2 @dots{} -Outputs a warning message containing the arguments. -@end deffn - -@deffn Procedure slib:error arg1 arg2 @dots{} -Outputs an error message containing the arguments, aborts evaluation of -the current form and responds in a system dependent way to the error. -Typical responses are to abort the program or to enter a read-eval-print -loop. -@end deffn - -@deffn Procedure slib:exit n -@deffnx Procedure slib:exit -Exits from the Scheme session returning status @var{n} to the system. -If @var{n} is omitted or @code{#t}, a success status is returned to the -system (if possible). If @var{n} is @code{#f} a failure is returned to -the system (if possible). If @var{n} is an integer, then @var{n} is -returned to the system (if possible). If the Scheme session cannot exit -an unspecified value is returned from @code{slib:exit}. -@end deffn - - -@node About this manual, , Built-in Support, The Library System -@section About this manual - -@itemize @bullet -@item -Entries that are labeled as Functions are called for their return -values. Entries that are labeled as Procedures are called primarily for -their side effects. - -@item -Examples in this text were produced using the @code{scm} Scheme -implementation. - -@item -At the beginning of each section, there is a line that looks like -@ftindex feature -@code{(require 'feature)}. Include this line in your code prior to -using the package. -@end itemize - - -@node Scheme Syntax Extension Packages, Textual Conversion Packages, The Library System, Top -@chapter Scheme Syntax Extension Packages - -@menu -* Defmacro:: Supported by all implementations - -* R4RS Macros:: 'macro -* Macro by Example:: 'macro-by-example -* Macros That Work:: 'macros-that-work -* Syntactic Closures:: 'syntactic-closures -* Syntax-Case Macros:: 'syntax-case - -Syntax extensions (macros) included with SLIB. Also @xref{Structures}. - -* Fluid-Let:: 'fluid-let -* Yasos:: 'yasos, 'oop, 'collect -@end menu - - -@node Defmacro, R4RS Macros, Scheme Syntax Extension Packages, Scheme Syntax Extension Packages -@section Defmacro - -Defmacros are supported by all implementations. -@c See also @code{gentemp}, in @ref{Macros}. - -@defun gentemp -Returns a new (interned) symbol each time it is called. The symbol -names are implementation-dependent -@lisp -(gentemp) @result{} scm:G0 -(gentemp) @result{} scm:G1 -@end lisp -@end defun - -@defun defmacro:eval e -Returns the @code{slib:eval} of expanding all defmacros in scheme -expression @var{e}. -@end defun - -@defun defmacro:load filename -@var{filename} should be a string. If filename names an existing file, -the @code{defmacro:load} procedure reads Scheme source code expressions -and definitions from the file and evaluates them sequentially. These -source code expressions and definitions may contain defmacro -definitions. The @code{macro:load} procedure does not affect the values -returned by @code{current-input-port} and -@code{current-output-port}. -@end defun - -@defun defmacro? sym -Returns @code{#t} if @var{sym} has been defined by @code{defmacro}, -@code{#f} otherwise. -@end defun - -@defun macroexpand-1 form -@defunx macroexpand form -If @var{form} is a macro call, @code{macroexpand-1} will expand the -macro call once and return it. A @var{form} is considered to be a macro -call only if it is a cons whose @code{car} is a symbol for which a -@code{defmacro} has been defined. - -@code{macroexpand} is similar to @code{macroexpand-1}, but repeatedly -expands @var{form} until it is no longer a macro call. -@end defun - -@defmac defmacro name lambda-list form @dots{} -When encountered by @code{defmacro:eval}, @code{defmacro:macroexpand*}, -or @code{defmacro:load} defines a new macro which will henceforth be -expanded when encountered by @code{defmacro:eval}, -@code{defmacro:macroexpand*}, or @code{defmacro:load}. -@end defmac - -@subsection Defmacroexpand -@code{(require 'defmacroexpand)} -@ftindex defmacroexpand - -@defun defmacro:expand* e -Returns the result of expanding all defmacros in scheme expression -@var{e}. -@end defun - -@node R4RS Macros, Macro by Example, Defmacro, Scheme Syntax Extension Packages -@section R4RS Macros - -@code{(require 'macro)} is the appropriate call if you want R4RS -@ftindex macro -high-level macros but don't care about the low level implementation. If -an SLIB R4RS macro implementation is already loaded it will be used. -Otherwise, one of the R4RS macros implemetations is loaded. - -The SLIB R4RS macro implementations support the following uniform -interface: - -@defun macro:expand sexpression -Takes an R4RS expression, macro-expands it, and returns the result of -the macro expansion. -@end defun - -@defun macro:eval sexpression -Takes an R4RS expression, macro-expands it, evals the result of the -macro expansion, and returns the result of the evaluation. -@end defun - -@deffn Procedure macro:load filename -@var{filename} should be a string. If filename names an existing file, -the @code{macro:load} procedure reads Scheme source code expressions and -definitions from the file and evaluates them sequentially. These source -code expressions and definitions may contain macro definitions. The -@code{macro:load} procedure does not affect the values returned by -@code{current-input-port} and @code{current-output-port}. -@end deffn - -@node Macro by Example, Macros That Work, R4RS Macros, Scheme Syntax Extension Packages -@section Macro by Example - -@code{(require 'macro-by-example)} -@ftindex macro-by-example - -A vanilla implementation of @cite{Macro by Example} (Eugene Kohlbecker, -R4RS) by Dorai Sitaram, (dorai@@cs.rice.edu) using @code{defmacro}. - -@itemize @bullet - -@item -generating hygienic global @code{define-syntax} Macro-by-Example macros -@strong{cheaply}. - -@item -can define macros which use @code{...}. - -@item -needn't worry about a lexical variable in a macro definition -clashing with a variable from the macro use context - -@item -don't suffer the overhead of redefining the repl if @code{defmacro} -natively supported (most implementations) - -@end itemize -@subsection Caveat -These macros are not referentially transparent (@pxref{Macros, , ,r4rs, -Revised(4) Scheme}). Lexically scoped macros (i.e., @code{let-syntax} -and @code{letrec-syntax}) are not supported. In any case, the problem -of referential transparency gains poignancy only when @code{let-syntax} -and @code{letrec-syntax} are used. So you will not be courting -large-scale disaster unless you're using system-function names as local -variables with unintuitive bindings that the macro can't use. However, -if you must have the full @cite{r4rs} macro functionality, look to the -more featureful (but also more expensive) versions of syntax-rules -available in slib @ref{Macros That Work}, @ref{Syntactic Closures}, and -@ref{Syntax-Case Macros}. - -@defmac define-syntax keyword transformer-spec -The @var{keyword} is an identifier, and the @var{transformer-spec} -should be an instance of @code{syntax-rules}. - -The top-level syntactic environment is extended by binding the -@var{keyword} to the specified transformer. - -@example -(define-syntax let* - (syntax-rules () - ((let* () body1 body2 ...) - (let () body1 body2 ...)) - ((let* ((name1 val1) (name2 val2) ...) - body1 body2 ...) - (let ((name1 val1)) - (let* (( name2 val2) ...) - body1 body2 ...))))) -@end example -@end defmac - -@defmac syntax-rules literals syntax-rule @dots{} -@var{literals} is a list of identifiers, and each @var{syntax-rule} -should be of the form - -@code{(@var{pattern} @var{template})} - -where the @var{pattern} and @var{template} are as in the grammar above. - -An instance of @code{syntax-rules} produces a new macro transformer by -specifying a sequence of hygienic rewrite rules. A use of a macro whose -keyword is associated with a transformer specified by -@code{syntax-rules} is matched against the patterns contained in the -@var{syntax-rule}s, beginning with the leftmost @var{syntax-rule}. -When a match is found, the macro use is trancribed hygienically -according to the template. - -Each pattern begins with the keyword for the macro. This keyword is not -involved in the matching and is not considered a pattern variable or -literal identifier. -@end defmac - -@node Macros That Work, Syntactic Closures, Macro by Example, Scheme Syntax Extension Packages -@section Macros That Work - -@code{(require 'macros-that-work)} -@ftindex macros-that-work - -@cite{Macros That Work} differs from the other R4RS macro -implementations in that it does not expand derived expression types to -primitive expression types. - -@defun macro:expand expression -@defunx macwork:expand expression -Takes an R4RS expression, macro-expands it, and returns the result of -the macro expansion. -@end defun - -@defun macro:eval expression -@defunx macwork:eval expression -@code{macro:eval} returns the value of @var{expression} in the current -top level environment. @var{expression} can contain macro definitions. -Side effects of @var{expression} will affect the top level -environment. -@end defun - -@deffn Procedure macro:load filename -@deffnx Procedure macwork:load filename -@var{filename} should be a string. If filename names an existing file, -the @code{macro:load} procedure reads Scheme source code expressions and -definitions from the file and evaluates them sequentially. These source -code expressions and definitions may contain macro definitions. The -@code{macro:load} procedure does not affect the values returned by -@code{current-input-port} and @code{current-output-port}. -@end deffn - -References: - -The @cite{Revised^4 Report on the Algorithmic Language Scheme} Clinger -and Rees [editors]. To appear in LISP Pointers. Also available as a -technical report from the University of Oregon, MIT AI Lab, and -Cornell. - -@center Macros That Work. Clinger and Rees. POPL '91. - -The supported syntax differs from the R4RS in that vectors are allowed -as patterns and as templates and are not allowed as pattern or template -data. - -@example -transformer spec @expansion{} (syntax-rules literals rules) - -rules @expansion{} () - | (rule . rules) - -rule @expansion{} (pattern template) - -pattern @expansion{} pattern_var ; a symbol not in literals - | symbol ; a symbol in literals - | () - | (pattern . pattern) - | (ellipsis_pattern) - | #(pattern*) ; extends R4RS - | #(pattern* ellipsis_pattern) ; extends R4RS - | pattern_datum - -template @expansion{} pattern_var - | symbol - | () - | (template2 . template2) - | #(template*) ; extends R4RS - | pattern_datum - -template2 @expansion{} template - | ellipsis_template - -pattern_datum @expansion{} string ; no vector - | character - | boolean - | number - -ellipsis_pattern @expansion{} pattern ... - -ellipsis_template @expansion{} template ... - -pattern_var @expansion{} symbol ; not in literals - -literals @expansion{} () - | (symbol . literals) -@end example - -@subsection Definitions - -@table @asis - -@item Scope of an ellipsis -Within a pattern or template, the scope of an ellipsis (@code{...}) is -the pattern or template that appears to its left. - -@item Rank of a pattern variable -The rank of a pattern variable is the number of ellipses within whose -scope it appears in the pattern. - -@item Rank of a subtemplate -The rank of a subtemplate is the number of ellipses within whose scope -it appears in the template. - -@item Template rank of an occurrence of a pattern variable -The template rank of an occurrence of a pattern variable within a -template is the rank of that occurrence, viewed as a subtemplate. - -@item Variables bound by a pattern -The variables bound by a pattern are the pattern variables that appear -within it. - -@item Referenced variables of a subtemplate -The referenced variables of a subtemplate are the pattern variables that -appear within it. - -@item Variables opened by an ellipsis template -The variables opened by an ellipsis template are the referenced pattern -variables whose rank is greater than the rank of the ellipsis template. - -@end table - -@subsection Restrictions - -No pattern variable appears more than once within a pattern. - -For every occurrence of a pattern variable within a template, the -template rank of the occurrence must be greater than or equal to the -pattern variable's rank. - -Every ellipsis template must open at least one variable. - -For every ellipsis template, the variables opened by an ellipsis -template must all be bound to sequences of the same length. - -The compiled form of a @var{rule} is - -@example -rule @expansion{} (pattern template inserted) - -pattern @expansion{} pattern_var - | symbol - | () - | (pattern . pattern) - | ellipsis_pattern - | #(pattern) - | pattern_datum - -template @expansion{} pattern_var - | symbol - | () - | (template2 . template2) - | #(pattern) - | pattern_datum - -template2 @expansion{} template - | ellipsis_template - -pattern_datum @expansion{} string - | character - | boolean - | number - -pattern_var @expansion{} #(V symbol rank) - -ellipsis_pattern @expansion{} #(E pattern pattern_vars) - -ellipsis_template @expansion{} #(E template pattern_vars) - -inserted @expansion{} () - | (symbol . inserted) - -pattern_vars @expansion{} () - | (pattern_var . pattern_vars) - -rank @expansion{} exact non-negative integer -@end example - -where V and E are unforgeable values. - -The pattern variables associated with an ellipsis pattern are the -variables bound by the pattern, and the pattern variables associated -with an ellipsis template are the variables opened by the ellipsis -template. - -If the template contains a big chunk that contains no pattern variables -or inserted identifiers, then the big chunk will be copied -unnecessarily. That shouldn't matter very often. - - - - - -@node Syntactic Closures, Syntax-Case Macros, Macros That Work, Scheme Syntax Extension Packages -@section Syntactic Closures - -@code{(require 'syntactic-closures)} -@ftindex syntactic-closures - -@defun macro:expand expression -@defunx synclo:expand expression -Returns scheme code with the macros and derived expression types of -@var{expression} expanded to primitive expression types. -@end defun - -@defun macro:eval expression -@defunx synclo:eval expression -@code{macro:eval} returns the value of @var{expression} in the current -top level environment. @var{expression} can contain macro definitions. -Side effects of @var{expression} will affect the top level -environment. -@end defun - -@deffn Procedure macro:load filename -@deffnx Procedure synclo:load filename -@var{filename} should be a string. If filename names an existing file, -the @code{macro:load} procedure reads Scheme source code expressions and -definitions from the file and evaluates them sequentially. These -source code expressions and definitions may contain macro definitions. -The @code{macro:load} procedure does not affect the values returned by -@code{current-input-port} and @code{current-output-port}. -@end deffn - -@subsection Syntactic Closure Macro Facility - -@center A Syntactic Closures Macro Facility -@center by Chris Hanson -@center 9 November 1991 - -This document describes @dfn{syntactic closures}, a low-level macro -facility for the Scheme programming language. The facility is an -alternative to the low-level macro facility described in the -@cite{Revised^4 Report on Scheme.} This document is an addendum to that -report. - -The syntactic closures facility extends the BNF rule for -@var{transformer spec} to allow a new keyword that introduces a -low-level macro transformer:@refill -@example -@var{transformer spec} := (transformer @var{expression}) -@end example - -Additionally, the following procedures are added: -@lisp -make-syntactic-closure -capture-syntactic-environment -identifier? -identifier=? -@end lisp - -The description of the facility is divided into three parts. The first -part defines basic terminology. The second part describes how macro -transformers are defined. The third part describes the use of -@dfn{identifiers}, which extend the syntactic closure mechanism to be -compatible with @code{syntax-rules}. - -@subsubsection Terminology - -This section defines the concepts and data types used by the syntactic -closures facility. - -@itemize @bullet - -@item @dfn{Forms} are the syntactic entities out of which programs are -recursively constructed. A form is any expression, any definition, any -syntactic keyword, or any syntactic closure. The variable name that -appears in a @code{set!} special form is also a form. Examples of -forms:@refill -@lisp -17 -#t -car -(+ x 4) -(lambda (x) x) -(define pi 3.14159) -if -define -@end lisp - -@item An @dfn{alias} is an alternate name for a given symbol. It can -appear anywhere in a form that the symbol could be used, and when quoted -it is replaced by the symbol; however, it does not satisfy the predicate -@code{symbol?}. Macro transformers rarely distinguish symbols from -aliases, referring to both as identifiers. - -@item A @dfn{syntactic} environment maps identifiers to their -meanings. More precisely, it determines whether an identifier is a -syntactic keyword or a variable. If it is a keyword, the meaning is an -interpretation for the form in which that keyword appears. If it is a -variable, the meaning identifies which binding of that variable is -referenced. In short, syntactic environments contain all of the -contextual information necessary for interpreting the meaning of a -particular form. - -@item A @dfn{syntactic closure} consists of a form, a syntactic -environment, and a list of identifiers. All identifiers in the form -take their meaning from the syntactic environment, except those in the -given list. The identifiers in the list are to have their meanings -determined later. A syntactic closure may be used in any context in -which its form could have been used. Since a syntactic closure is also -a form, it may not be used in contexts where a form would be illegal. -For example, a form may not appear as a clause in the cond special form. -A syntactic closure appearing in a quoted structure is replaced by its -form. - -@end itemize - -@subsubsection Transformer Definition - -This section describes the @code{transformer} special form and the -procedures @code{make-syntactic-closure} and -@code{capture-syntactic-environment}. - -@deffn Syntax transformer expression - -Syntax: It is an error if this syntax occurs except as a -@var{transformer spec}. - -Semantics: The @var{expression} is evaluated in the standard transformer -environment to yield a macro transformer as described below. This macro -transformer is bound to a macro keyword by the special form in which the -@code{transformer} expression appears (for example, -@code{let-syntax}). - -A @dfn{macro transformer} is a procedure that takes two arguments, a -form and a syntactic environment, and returns a new form. The first -argument, the @dfn{input form}, is the form in which the macro keyword -occurred. The second argument, the @dfn{usage environment}, is the -syntactic environment in which the input form occurred. The result of -the transformer, the @dfn{output form}, is automatically closed in the -@dfn{transformer environment}, which is the syntactic environment in -which the @code{transformer} expression occurred. - -For example, here is a definition of a push macro using -@code{syntax-rules}:@refill -@lisp -(define-syntax push - (syntax-rules () - ((push item list) - (set! list (cons item list))))) -@end lisp - -Here is an equivalent definition using @code{transformer}: -@lisp -(define-syntax push - (transformer - (lambda (exp env) - (let ((item - (make-syntactic-closure env '() (cadr exp))) - (list - (make-syntactic-closure env '() (caddr exp)))) - `(set! ,list (cons ,item ,list)))))) -@end lisp - -In this example, the identifiers @code{set!} and @code{cons} are closed -in the transformer environment, and thus will not be affected by the -meanings of those identifiers in the usage environment -@code{env}. - -Some macros may be non-hygienic by design. For example, the following -defines a loop macro that implicitly binds @code{exit} to an escape -procedure. The binding of @code{exit} is intended to capture free -references to @code{exit} in the body of the loop, so @code{exit} must -be left free when the body is closed:@refill -@lisp -(define-syntax loop - (transformer - (lambda (exp env) - (let ((body (cdr exp))) - `(call-with-current-continuation - (lambda (exit) - (let f () - ,@@(map (lambda (exp) - (make-syntactic-closure env '(exit) - exp)) - body) - (f)))))))) -@end lisp - -To assign meanings to the identifiers in a form, use -@code{make-syntactic-closure} to close the form in a syntactic -environment. -@end deffn - -@defun make-syntactic-closure environment free-names form - -@var{environment} must be a syntactic environment, @var{free-names} must -be a list of identifiers, and @var{form} must be a form. -@code{make-syntactic-closure} constructs and returns a syntactic closure -of @var{form} in @var{environment}, which can be used anywhere that -@var{form} could have been used. All the identifiers used in -@var{form}, except those explicitly excepted by @var{free-names}, obtain -their meanings from @var{environment}. - -Here is an example where @var{free-names} is something other than the -empty list. It is instructive to compare the use of @var{free-names} in -this example with its use in the @code{loop} example above: the examples -are similar except for the source of the identifier being left -free. -@lisp -(define-syntax let1 - (transformer - (lambda (exp env) - (let ((id (cadr exp)) - (init (caddr exp)) - (exp (cadddr exp))) - `((lambda (,id) - ,(make-syntactic-closure env (list id) exp)) - ,(make-syntactic-closure env '() init)))))) -@end lisp - -@code{let1} is a simplified version of @code{let} that only binds a -single identifier, and whose body consists of a single expression. When -the body expression is syntactically closed in its original syntactic -environment, the identifier that is to be bound by @code{let1} must be -left free, so that it can be properly captured by the @code{lambda} in -the output form. - -To obtain a syntactic environment other than the usage environment, use -@code{capture-syntactic-environment}. -@end defun - -@defun capture-syntactic-environment procedure - -@code{capture-syntactic-environment} returns a form that will, when -transformed, call @var{procedure} on the current syntactic environment. -@var{procedure} should compute and return a new form to be transformed, -in that same syntactic environment, in place of the form. - -An example will make this clear. Suppose we wanted to define a simple -@code{loop-until} keyword equivalent to@refill -@lisp -(define-syntax loop-until - (syntax-rules () - ((loop-until id init test return step) - (letrec ((loop - (lambda (id) - (if test return (loop step))))) - (loop init))))) -@end lisp - -The following attempt at defining @code{loop-until} has a subtle bug: -@lisp -(define-syntax loop-until - (transformer - (lambda (exp env) - (let ((id (cadr exp)) - (init (caddr exp)) - (test (cadddr exp)) - (return (cadddr (cdr exp))) - (step (cadddr (cddr exp))) - (close - (lambda (exp free) - (make-syntactic-closure env free exp)))) - `(letrec ((loop - (lambda (,id) - (if ,(close test (list id)) - ,(close return (list id)) - (loop ,(close step (list id))))))) - (loop ,(close init '()))))))) -@end lisp - -This definition appears to take all of the proper precautions to prevent -unintended captures. It carefully closes the subexpressions in their -original syntactic environment and it leaves the @code{id} identifier -free in the @code{test}, @code{return}, and @code{step} expressions, so -that it will be captured by the binding introduced by the @code{lambda} -expression. Unfortunately it uses the identifiers @code{if} and -@code{loop} within that @code{lambda} expression, so if the user of -@code{loop-until} just happens to use, say, @code{if} for the -identifier, it will be inadvertently captured. - -The syntactic environment that @code{if} and @code{loop} want to be -exposed to is the one just outside the @code{lambda} expression: before -the user's identifier is added to the syntactic environment, but after -the identifier loop has been added. -@code{capture-syntactic-environment} captures exactly that environment -as follows:@refill -@lisp -(define-syntax loop-until - (transformer - (lambda (exp env) - (let ((id (cadr exp)) - (init (caddr exp)) - (test (cadddr exp)) - (return (cadddr (cdr exp))) - (step (cadddr (cddr exp))) - (close - (lambda (exp free) - (make-syntactic-closure env free exp)))) - `(letrec ((loop - ,(capture-syntactic-environment - (lambda (env) - `(lambda (,id) - (,(make-syntactic-closure env '() `if) - ,(close test (list id)) - ,(close return (list id)) - (,(make-syntactic-closure env '() - `loop) - ,(close step (list id))))))))) - (loop ,(close init '()))))))) -@end lisp - -In this case, having captured the desired syntactic environment, it is -convenient to construct syntactic closures of the identifiers @code{if} -and the @code{loop} and use them in the body of the -@code{lambda}. - -A common use of @code{capture-syntactic-environment} is to get the -transformer environment of a macro transformer:@refill -@lisp -(transformer - (lambda (exp env) - (capture-syntactic-environment - (lambda (transformer-env) - ...)))) -@end lisp -@end defun - -@subsubsection Identifiers - -This section describes the procedures that create and manipulate -identifiers. Previous syntactic closure proposals did not have an -identifier data type -- they just used symbols. The identifier data -type extends the syntactic closures facility to be compatible with the -high-level @code{syntax-rules} facility. - -As discussed earlier, an identifier is either a symbol or an -@dfn{alias}. An alias is implemented as a syntactic closure whose -@dfn{form} is an identifier:@refill -@lisp -(make-syntactic-closure env '() 'a) - @result{} an @dfn{alias} -@end lisp - -Aliases are implemented as syntactic closures because they behave just -like syntactic closures most of the time. The difference is that an -alias may be bound to a new value (for example by @code{lambda} or -@code{let-syntax}); other syntactic closures may not be used this way. -If an alias is bound, then within the scope of that binding it is looked -up in the syntactic environment just like any other identifier. - -Aliases are used in the implementation of the high-level facility -@code{syntax-rules}. A macro transformer created by @code{syntax-rules} -uses a template to generate its output form, substituting subforms of -the input form into the template. In a syntactic closures -implementation, all of the symbols in the template are replaced by -aliases closed in the transformer environment, while the output form -itself is closed in the usage environment. This guarantees that the -macro transformation is hygienic, without requiring the transformer to -know the syntactic roles of the substituted input subforms. - -@defun identifier? object -Returns @code{#t} if @var{object} is an identifier, otherwise returns -@code{#f}. Examples:@refill -@lisp -(identifier? 'a) - @result{} #t -(identifier? (make-syntactic-closure env '() 'a)) - @result{} #t -(identifier? "a") - @result{} #f -(identifier? #\a) - @result{} #f -(identifier? 97) - @result{} #f -(identifier? #f) - @result{} #f -(identifier? '(a)) - @result{} #f -(identifier? '#(a)) - @result{} #f -@end lisp - -The predicate @code{eq?} is used to determine if two identifers are -``the same''. Thus @code{eq?} can be used to compare identifiers -exactly as it would be used to compare symbols. Often, though, it is -useful to know whether two identifiers ``mean the same thing''. For -example, the @code{cond} macro uses the symbol @code{else} to identify -the final clause in the conditional. A macro transformer for -@code{cond} cannot just look for the symbol @code{else}, because the -@code{cond} form might be the output of another macro transformer that -replaced the symbol @code{else} with an alias. Instead the transformer -must look for an identifier that ``means the same thing'' in the usage -environment as the symbol @code{else} means in the transformer -environment. -@end defun - -@defun identifier=? environment1 identifier1 environment2 identifier2 -@var{environment1} and @var{environment2} must be syntactic -environments, and @var{identifier1} and @var{identifier2} must be -identifiers. @code{identifier=?} returns @code{#t} if the meaning of -@var{identifier1} in @var{environment1} is the same as that of -@var{identifier2} in @var{environment2}, otherwise it returns @code{#f}. -Examples:@refill - -@lisp -(let-syntax - ((foo - (transformer - (lambda (form env) - (capture-syntactic-environment - (lambda (transformer-env) - (identifier=? transformer-env 'x env 'x))))))) - (list (foo) - (let ((x 3)) - (foo)))) - @result{} (#t #f) -@end lisp - -@lisp -(let-syntax ((bar foo)) - (let-syntax - ((foo - (transformer - (lambda (form env) - (capture-syntactic-environment - (lambda (transformer-env) - (identifier=? transformer-env 'foo - env (cadr form)))))))) - (list (foo foo) - (foobar)))) - @result{} (#f #t) -@end lisp -@end defun - -@subsubsection Acknowledgements - -The syntactic closures facility was invented by Alan Bawden and Jonathan -Rees. The use of aliases to implement @code{syntax-rules} was invented -by Alan Bawden (who prefers to call them @dfn{synthetic names}). Much -of this proposal is derived from an earlier proposal by Alan -Bawden. - - - - - -@node Syntax-Case Macros, Fluid-Let, Syntactic Closures, Scheme Syntax Extension Packages -@section Syntax-Case Macros - -@code{(require 'syntax-case)} -@ftindex syntax-case - -@defun macro:expand expression -@defunx syncase:expand expression -Returns scheme code with the macros and derived expression types of -@var{expression} expanded to primitive expression types. -@end defun - -@defun macro:eval expression -@defunx syncase:eval expression -@code{macro:eval} returns the value of @var{expression} in the current -top level environment. @var{expression} can contain macro definitions. -Side effects of @var{expression} will affect the top level -environment. -@end defun - -@deffn Procedure macro:load filename -@deffnx Procedure syncase:load filename -@var{filename} should be a string. If filename names an existing file, -the @code{macro:load} procedure reads Scheme source code expressions and -definitions from the file and evaluates them sequentially. These -source code expressions and definitions may contain macro definitions. -The @code{macro:load} procedure does not affect the values returned by -@code{current-input-port} and @code{current-output-port}. -@end deffn - -This is version 2.1 of @code{syntax-case}, the low-level macro facility -proposed and implemented by Robert Hieb and R. Kent Dybvig. - -This version is further adapted by Harald Hanche-Olsen - to make it compatible with, and easily usable -with, SLIB. Mainly, these adaptations consisted of: - -@itemize @bullet -@item -Removing white space from @file{expand.pp} to save space in the -distribution. This file is not meant for human readers anyway@dots{} - -@item -Removed a couple of Chez scheme dependencies. - -@item -Renamed global variables used to minimize the possibility of name -conflicts. - -@item -Adding an SLIB-specific initialization file. - -@item -Removing a couple extra files, most notably the documentation (but see -below). -@end itemize - -If you wish, you can see exactly what changes were done by reading the -shell script in the file @file{syncase.sh}. - -The two PostScript files were omitted in order to not burden the SLIB -distribution with them. If you do intend to use @code{syntax-case}, -however, you should get these files and print them out on a PostScript -printer. They are available with the original @code{syntax-case} -distribution by anonymous FTP in -@file{cs.indiana.edu:/pub/scheme/syntax-case}. - -In order to use syntax-case from an interactive top level, execute: -@lisp -(require 'syntax-case) -@ftindex syntax-case -(require 'repl) -@ftindex repl -(repl:top-level macro:eval) -@end lisp -See the section Repl (@pxref{Repl}) for more information. - -To check operation of syntax-case get -@file{cs.indiana.edu:/pub/scheme/syntax-case}, and type -@lisp -(require 'syntax-case) -@ftindex syntax-case -(syncase:sanity-check) -@end lisp - -Beware that @code{syntax-case} takes a long time to load -- about 20s on -a SPARCstation SLC (with SCM) and about 90s on a Macintosh SE/30 (with -Gambit). - -@subsection Notes - -All R4RS syntactic forms are defined, including @code{delay}. Along -with @code{delay} are simple definitions for @code{make-promise} (into -which @code{delay} expressions expand) and @code{force}. - -@code{syntax-rules} and @code{with-syntax} (described in @cite{TR356}) -are defined. - -@code{syntax-case} is actually defined as a macro that expands into -calls to the procedure @code{syntax-dispatch} and the core form -@code{syntax-lambda}; do not redefine these names. - -Several other top-level bindings not documented in TR356 are created: -@itemize @bullet -@item the ``hooks'' in @file{hooks.ss} -@item the @code{build-} procedures in @file{output.ss} -@item @code{expand-syntax} (the expander) -@end itemize - -The syntax of define has been extended to allow @code{(define @var{id})}, -which assigns @var{id} to some unspecified value. - -We have attempted to maintain R4RS compatibility where possible. The -incompatibilities should be confined to @file{hooks.ss}. Please let us -know if there is some incompatibility that is not flagged as such. - -Send bug reports, comments, suggestions, and questions to Kent Dybvig -(dyb@@iuvax.cs.indiana.edu). - -@subsection Note from maintainer - -Included with the @code{syntax-case} files was @file{structure.scm} -which defines a macro @code{define-structure}. There is no -documentation for this macro and it is not used by any code in SLIB. - -@node Fluid-Let, Yasos, Syntax-Case Macros, Scheme Syntax Extension Packages -@section Fluid-Let - -@code{(require 'fluid-let)} -@ftindex fluid-let - -@deffn Syntax fluid-let @code{(@var{bindings} @dots{})} @var{forms}@dots{} -@end deffn -@lisp -(fluid-let ((@var{variable} @var{init}) @dots{}) - @var{expression} @var{expression} @dots{}) -@end lisp - -The @var{init}s are evaluated in the current environment (in some -unspecified order), the current values of the @var{variable}s are saved, -the results are assigned to the @var{variable}s, the @var{expression}s -are evaluated sequentially in the current environment, the -@var{variable}s are restored to their original values, and the value of -the last @var{expression} is returned. - -The syntax of this special form is similar to that of @code{let}, but -@code{fluid-let} temporarily rebinds existing @var{variable}s. Unlike -@code{let}, @code{fluid-let} creates no new bindings; instead it -@emph{assigns} the values of each @var{init} to the binding (determined -by the rules of lexical scoping) of its corresponding -@var{variable}. - - -@node Yasos, , Fluid-Let, Scheme Syntax Extension Packages -@section Yasos - -@c Much of the documentation in this section was written by Dave Love -@c (d.love@dl.ac.uk) -- don't blame Ken Dickey for its faults. -@c but we can blame him for not writing it! - -@code{(require 'oop)} or @code{(require 'yasos)} -@ftindex oop -@ftindex yasos - -`Yet Another Scheme Object System' is a simple object system for Scheme -based on the paper by Norman Adams and Jonathan Rees: @cite{Object -Oriented Programming in Scheme}, Proceedings of the 1988 ACM Conference -on LISP and Functional Programming, July 1988 [ACM #552880]. - -Another reference is: - -Ken Dickey. -@ifset html - -@end ifset -Scheming with Objects -@ifset html - -@end ifset -@cite{AI Expert} Volume 7, Number 10 (October 1992), pp. 24-33. - -@menu -* Yasos terms:: Definitions and disclaimer. -* Yasos interface:: The Yasos macros and procedures. -* Setters:: Dylan-like setters in Yasos. -* Yasos examples:: Usage of Yasos and setters. -@end menu - -@node Yasos terms, Yasos interface, Yasos, Yasos -@subsection Terms - -@table @asis -@item @dfn{Object} -Any Scheme data object. - -@item @dfn{Instance} -An instance of the OO system; an @dfn{object}. - -@item @dfn{Operation} -A @var{method}. -@end table - -@table @emph -@item Notes: -The object system supports multiple inheritance. An instance can -inherit from 0 or more ancestors. In the case of multiple inherited -operations with the same identity, the operation used is that from the -first ancestor which contains it (in the ancestor @code{let}). An -operation may be applied to any Scheme data object---not just instances. -As code which creates instances is just code, there are no @dfn{classes} -and no meta-@var{anything}. Method dispatch is by a procedure call a la -CLOS rather than by @code{send} syntax a la Smalltalk. - -@item Disclaimer: -There are a number of optimizations which can be made. This -implementation is expository (although performance should be quite -reasonable). See the L&FP paper for some suggestions. -@end table - - - - - -@node Yasos interface, Setters, Yasos terms, Yasos -@subsection Interface - -@deffn Syntax define-operation @code{(}opname self arg @dots{}@code{)} @var{default-body} -Defines a default behavior for data objects which don't handle the -operation @var{opname}. The default behavior (for an empty -@var{default-body}) is to generate an error. -@end deffn - -@deffn Syntax define-predicate opname? -Defines a predicate @var{opname?}, usually used for determining the -@dfn{type} of an object, such that @code{(@var{opname?} @var{object})} -returns @code{#t} if @var{object} has an operation @var{opname?} and -@code{#f} otherwise. -@end deffn - -@deffn Syntax object @code{((@var{name} @var{self} @var{arg} @dots{}) @var{body})} @dots{} -Returns an object (an instance of the object system) with operations. -Invoking @code{(@var{name} @var{object} @var{arg} @dots{}} executes the -@var{body} of the @var{object} with @var{self} bound to @var{object} and -with argument(s) @var{arg}@dots{}. -@end deffn - -@deffn Syntax object-with-ancestors @code{((}ancestor1 init1@code{)} @dots{}@code{)} operation @dots{} -A @code{let}-like form of @code{object} for multiple inheritance. It -returns an object inheriting the behaviour of @var{ancestor1} etc. An -operation will be invoked in an ancestor if the object itself does not -provide such a method. In the case of multiple inherited operations -with the same identity, the operation used is the one found in the first -ancestor in the ancestor list. -@end deffn - -@deffn Syntax operate-as component operation self arg @dots{} -Used in an operation definition (of @var{self}) to invoke the -@var{operation} in an ancestor @var{component} but maintain the object's -identity. Also known as ``send-to-super''. -@end deffn - -@deffn Procedure print obj port -A default @code{print} operation is provided which is just @code{(format -@var{port} @var{obj})} (@pxref{Format}) for non-instances and prints -@var{obj} preceded by @samp{#} for instances. -@end deffn - -@defun size obj -The default method returns the number of elements in @var{obj} if it is -a vector, string or list, @code{2} for a pair, @code{1} for a character -and by default id an error otherwise. Objects such as collections -(@pxref{Collections}) may override the default in an obvious way. -@end defun - - - - - -@node Setters, Yasos examples, Yasos interface, Yasos -@subsection Setters - -@dfn{Setters} implement @dfn{generalized locations} for objects -associated with some sort of mutable state. A @dfn{getter} operation -retrieves a value from a generalized location and the corresponding -setter operation stores a value into the location. Only the getter is -named -- the setter is specified by a procedure call as below. (Dylan -uses special syntax.) Typically, but not necessarily, getters are -access operations to extract values from Yasos objects (@pxref{Yasos}). -Several setters are predefined, corresponding to getters @code{car}, -@code{cdr}, @code{string-ref} and @code{vector-ref} e.g., @code{(setter -car)} is equivalent to @code{set-car!}. - -This implementation of setters is similar to that in Dylan(TM) -(@cite{Dylan: An object-oriented dynamic language}, Apple Computer -Eastern Research and Technology). Common LISP provides similar -facilities through @code{setf}. - -@defun setter getter -Returns the setter for the procedure @var{getter}. E.g., since -@code{string-ref} is the getter corresponding to a setter which is -actually @code{string-set!}: -@example -(define foo "foo") -((setter string-ref) foo 0 #\F) ; set element 0 of foo -foo @result{} "Foo" -@end example -@end defun - -@deffn Syntax set place new-value -If @var{place} is a variable name, @code{set} is equivalent to -@code{set!}. Otherwise, @var{place} must have the form of a procedure -call, where the procedure name refers to a getter and the call indicates -an accessible generalized location, i.e., the call would return a value. -The return value of @code{set} is usually unspecified unless used with a -setter whose definition guarantees to return a useful value. -@example -(set (string-ref foo 2) #\O) ; generalized location with getter -foo @result{} "FoO" -(set foo "foo") ; like set! -foo @result{} "foo" -@end example -@end deffn - -@deffn Procedure add-setter getter setter -Add procedures @var{getter} and @var{setter} to the (inaccessible) list -of valid setter/getter pairs. @var{setter} implements the store -operation corresponding to the @var{getter} access operation for the -relevant state. The return value is unspecified. -@end deffn - -@deffn Procedure remove-setter-for getter -Removes the setter corresponding to the specified @var{getter} from the -list of valid setters. The return value is unspecified. -@end deffn - -@deffn Syntax define-access-operation getter-name -Shorthand for a Yasos @code{define-operation} defining an operation -@var{getter-name} that objects may support to return the value of some -mutable state. The default operation is to signal an error. The return -value is unspecified. -@end deffn - - - - - -@node Yasos examples, , Setters, Yasos -@subsection Examples - -@lisp -;;; These definitions for PRINT and SIZE are -;;; already supplied by -(require 'yasos) - -(define-operation (print obj port) - (format port - (if (instance? obj) "#" "~s") - obj)) - -(define-operation (size obj) - (cond - ((vector? obj) (vector-length obj)) - ((list? obj) (length obj)) - ((pair? obj) 2) - ((string? obj) (string-length obj)) - ((char? obj) 1) - (else - (error "Operation not supported: size" obj)))) - -(define-predicate cell?) -(define-operation (fetch obj)) -(define-operation (store! obj newValue)) - -(define (make-cell value) - (object - ((cell? self) #t) - ((fetch self) value) - ((store! self newValue) - (set! value newValue) - newValue) - ((size self) 1) - ((print self port) - (format port "#" (fetch self))))) - -(define-operation (discard obj value) - (format #t "Discarding ~s~%" value)) - -(define (make-filtered-cell value filter) - (object-with-ancestors - ((cell (make-cell value))) - ((store! self newValue) - (if (filter newValue) - (store! cell newValue) - (discard self newValue))))) - -(define-predicate array?) -(define-operation (array-ref array index)) -(define-operation (array-set! array index value)) - -(define (make-array num-slots) - (let ((anArray (make-vector num-slots))) - (object - ((array? self) #t) - ((size self) num-slots) - ((array-ref self index) - (vector-ref anArray index)) - ((array-set! self index newValue) - (vector-set! anArray index newValue)) - ((print self port) - (format port "#" (size self)))))) - -(define-operation (position obj)) -(define-operation (discarded-value obj)) - -(define (make-cell-with-history value filter size) - (let ((pos 0) (most-recent-discard #f)) - (object-with-ancestors - ((cell (make-filtered-call value filter)) - (sequence (make-array size))) - ((array? self) #f) - ((position self) pos) - ((store! self newValue) - (operate-as cell store! self newValue) - (array-set! self pos newValue) - (set! pos (+ pos 1))) - ((discard self value) - (set! most-recent-discard value)) - ((discarded-value self) most-recent-discard) - ((print self port) - (format port "#" - (fetch self)))))) - -(define-access-operation fetch) -(add-setter fetch store!) -(define foo (make-cell 1)) -(print foo #f) -@result{} "#" -(set (fetch foo) 2) -@result{} -(print foo #f) -@result{} "#" -(fetch foo) -@result{} 2 -@end lisp - -@node Textual Conversion Packages, Mathematical Packages, Scheme Syntax Extension Packages, Top -@chapter Textual Conversion Packages - -@menu -* Precedence Parsing:: -* Format:: Common-Lisp Format -* Standard Formatted I/O:: Posix printf and scanf -* Programs and Arguments:: -* HTML:: -* HTML Tables:: Databases meet HTML -* HTTP and CGI:: Serve WWW sites -* URI:: Uniform Resource Identifier -* Printing Scheme:: Nicely -* Time and Date:: -* Vector Graphics:: -* Schmooz:: Documentation markup for Scheme programs -@end menu - - -@node Precedence Parsing, Format, Textual Conversion Packages, Textual Conversion Packages -@section Precedence Parsing - -@code{(require 'precedence-parse)} or @code{(require 'parse)} -@ftindex parse -@ftindex precedence - -@noindent -This package implements: - -@itemize @bullet -@item -a Pratt style precedence parser; -@item -a @dfn{tokenizer} which congeals tokens according to assigned classes of -constituent characters; -@item -procedures giving direct control of parser rulesets; -@item -procedures for higher level specification of rulesets. -@end itemize - -@menu -* Precedence Parsing Overview:: -* Ruleset Definition and Use:: -* Token definition:: -* Nud and Led Definition:: -* Grammar Rule Definition:: -@end menu - -@node Precedence Parsing Overview, Ruleset Definition and Use, Precedence Parsing, Precedence Parsing -@subsection Precedence Parsing Overview - -@noindent -This package offers improvements over previous parsers. - -@itemize @bullet -@item -Common computer language constructs are concisely specified. -@item -Grammars can be changed dynamically. Operators can be assigned -different meanings within a lexical context. -@item -Rulesets don't need compilation. Grammars can be changed incrementally. -@item -Operator precedence is specified by integers. -@item -All possibilities of bad input are handled @footnote{How do I know this? -I parsed 250kbyte of random input (an e-mail file) with a non-trivial -grammar utilizing all constructs.} and return as much structure as was -parsed when the error occured; The symbol @code{?} is substituted for -missing input. -@end itemize - -@noindent -Here are the higher-level syntax types and an example of each. -Precedence considerations are omitted for clarity. See @ref{Grammar -Rule Definition} for full details. -@deftp Grammar nofix bye exit -@example -bye -@end example -calls the function @code{exit} with no arguments. -@end deftp -@deftp Grammar prefix - negate -@example -- 42 -@end example -Calls the function @code{negate} with the argument @code{42}. -@end deftp -@deftp Grammar infix - difference -@example -x - y -@end example -Calls the function @code{difference} with arguments @code{x} and @code{y}. -@end deftp -@deftp Grammar nary + sum -@example -x + y + z -@end example -Calls the function @code{sum} with arguments @code{x}, @code{y}, and -@code{y}. -@end deftp -@deftp Grammar postfix ! factorial -@example -5 ! -@end example -Calls the function @code{factorial} with the argument @code{5}. -@end deftp -@deftp Grammar prestfix set set! -@example -set foo bar -@end example -Calls the function @code{set!} with the arguments @code{foo} and -@code{bar}. -@end deftp -@deftp Grammar commentfix /* */ -@example -/* almost any text here */ -@end example -Ignores the comment delimited by @code{/*} and @code{*/}. -@end deftp -@deftp Grammar matchfix @{ list @} -@example -@{0, 1, 2@} -@end example -Calls the function @code{list} with the arguments @code{0}, @code{1}, -and @code{2}. -@end deftp -@deftp Grammar inmatchfix ( funcall ) -@example -f(x, y) -@end example -Calls the function @code{funcall} with the arguments @code{f}, @code{x}, -and @code{y}. -@end deftp -@deftp Grammar delim ; -@example -set foo bar; -@end example -delimits the extent of the restfix operator @code{set}. -@end deftp - - -@node Ruleset Definition and Use, Token definition, Precedence Parsing Overview, Precedence Parsing -@subsection Ruleset Definition and Use - -@defvar *syn-defs* -A grammar is built by one or more calls to @code{prec:define-grammar}. -The rules are appended to @var{*syn-defs*}. The value of -@var{*syn-defs*} is the grammar suitable for passing as an argument to -@code{prec:parse}. -@end defvar - -@defvr Constant *syn-ignore-whitespace* -Is a nearly empty grammar with whitespace characters set to group 0, -which means they will not be made into tokens. Most rulesets will want -to start with @code{*syn-ignore-whitespace*} -@end defvr - -@noindent -In order to start defining a grammar, either - -@example -(set! *syn-defs* '()) -@end example -@noindent -or - -@example -(set! *syn-defs* *syn-ignore-whitespace*) -@end example - -@defun prec:define-grammar rule1 @dots{} -Appends @var{rule1} @dots{} to @var{*syn-defs*}. -@code{prec:define-grammar} is used to define both the character classes -and rules for tokens. -@end defun - -@noindent -Once your grammar is defined, save the value of @code{*syn-defs*} in a -variable (for use when calling @code{prec:parse}). - -@example -(define my-ruleset *syn-defs*) -@end example - -@defun prec:parse ruleset delim -@defunx prec:parse ruleset delim port -The @var{ruleset} argument must be a list of rules as constructed by -@code{prec:define-grammar} and extracted from @var{*syn-defs*}. - -The token @var{delim} may be a character, symbol, or string. A -character @var{delim} argument will match only a character token; i.e. a -character for which no token-group is assigned. A symbols or string -will match only a token string; i.e. a token resulting from a token -group. - -@code{prec:parse} reads a @var{ruleset} grammar expression delimited -by @var{delim} from the given input @var{port}. @code{prec:parse} -returns the next object parsable from the given input @var{port}, -updating @var{port} to point to the first character past the end of the -external representation of the object. - -If an end of file is encountered in the input before any characters are -found that can begin an object, then an end of file object is returned. -If a delimiter (such as @var{delim}) is found before any characters are -found that can begin an object, then @code{#f} is returned. - -The @var{port} argument may be omitted, in which case it defaults to the -value returned by @code{current-input-port}. It is an error to parse -from a closed port. -@findex current-input-port -@end defun - -@node Token definition, Nud and Led Definition, Ruleset Definition and Use, Precedence Parsing -@subsection Token definition - -@defun tok:char-group group chars chars-proc -The argument @var{chars} may be a single character, a list of -characters, or a string. Each character in @var{chars} is treated as -though @code{tok:char-group} was called with that character alone. - -The argument @var{chars-proc} must be a procedure of one argument, a -list of characters. After @code{tokenize} has finished -accumulating the characters for a token, it calls @var{chars-proc} with -the list of characters. The value returned is the token which -@code{tokenize} returns. - -The argument @var{group} may be an exact integer or a procedure of one -character argument. The following discussion concerns the treatment -which the tokenizing routine, @code{tokenize}, will accord to characters -on the basis of their groups. - -When @var{group} is a non-zero integer, characters whose group number is -equal to or exactly one less than @var{group} will continue to -accumulate. Any other character causes the accumulation to stop (until -a new token is to be read). - -The @var{group} of zero is special. These characters are ignored when -parsed pending a token, and stop the accumulation of token characters -when the accumulation has already begun. Whitespace characters are -usually put in group 0. - -If @var{group} is a procedure, then, when triggerd by the occurence of -an initial (no accumulation) @var{chars} character, this procedure will -be repeatedly called with each successive character from the input -stream until the @var{group} procedure returns a non-false value. -@end defun - -@noindent -The following convenient constants are provided for use with -@code{tok:char-group}. - -@defvr Constant tok:decimal-digits -Is the string @code{"0123456789"}. -@end defvr -@defvr Constant tok:upper-case -Is the string consisting of all upper-case letters -("ABCDEFGHIJKLMNOPQRSTUVWXYZ"). -@end defvr -@defvr Constant tok:lower-case -Is the string consisting of all lower-case letters -("abcdefghijklmnopqrstuvwxyz"). -@end defvr -@defvr Constant tok:whitespaces -Is the string consisting of all characters between 0 and 255 for which -@code{char-whitespace?} returns true. -@end defvr - - -@node Nud and Led Definition, Grammar Rule Definition, Token definition, Precedence Parsing -@subsection Nud and Led Definition - -This section describes advanced features. You can skip this section on -first reading. - -@noindent -The @dfn{Null Denotation} (or @dfn{nud}) -@cindex Null Denotation, nud -of a token is the procedure and arguments applying for that token when -@dfn{Left}, an unclaimed parsed expression is not extant. - -@noindent -The @dfn{Left Denotation} (or @dfn{led}) -@cindex Left Denotation, led -of a token is the procedure, arguments, and lbp applying for that token -when there is a @dfn{Left}, an unclaimed parsed expression. - -@noindent -In his paper, - -@quotation -Pratt, V. R. -Top Down Operator Precendence. -@cite{SIGACT/SIGPLAN Symposium on Principles of Programming Languages}, -Boston, 1973, pages 41-51 -@end quotation - -the @dfn{left binding power} (or @dfn{lbp}) was an independent property -of tokens. I think this was done in order to allow tokens with NUDs but -not LEDs to also be used as delimiters, which was a problem for -statically defined syntaxes. It turns out that @emph{dynamically -binding} NUDs and LEDs allows them independence. - -@noindent -For the rule-defining procedures that follow, the variable @var{tk} may -be a character, string, or symbol, or a list composed of characters, -strings, and symbols. Each element of @var{tk} is treated as though the -procedure were called for each element. - -@noindent -Character @var{tk} arguments will match only character tokens; -i.e. characters for which no token-group is assigned. Symbols and -strings will both match token strings; i.e. tokens resulting from token -groups. - -@defun prec:make-nud tk sop arg1 @dots{} -Returns a rule specifying that @var{sop} be called when @var{tk} is -parsed. If @var{sop} is a procedure, it is called with @var{tk} and -@var{arg1} @dots{} as its arguments; the resulting value is incorporated -into the expression being built. Otherwise, @code{(list @var{sop} -@var{arg1} @dots{})} is incorporated. -@end defun - -@noindent -If no NUD has been defined for a token; then if that token is a string, -it is converted to a symbol and returned; if not a string, the token is -returned. - -@defun prec:make-led tk sop arg1 @dots{} -Returns a rule specifying that @var{sop} be called when @var{tk} is -parsed and @var{left} has an unclaimed parsed expression. If @var{sop} -is a procedure, it is called with @var{left}, @var{tk}, and @var{arg1} -@dots{} as its arguments; the resulting value is incorporated into the -expression being built. Otherwise, @var{left} is incorporated. -@end defun - -@noindent -If no LED has been defined for a token, and @var{left} is set, the -parser issues a warning. - -@node Grammar Rule Definition, , Nud and Led Definition, Precedence Parsing -@subsection Grammar Rule Definition - -@noindent -Here are procedures for defining rules for the syntax types introduced -in @ref{Precedence Parsing Overview}. - -@noindent -For the rule-defining procedures that follow, the variable @var{tk} may -be a character, string, or symbol, or a list composed of characters, -strings, and symbols. Each element of @var{tk} is treated as though the -procedure were called for each element. - -@noindent -For procedures prec:delim, @dots{}, prec:prestfix, if the @var{sop} -argument is @code{#f}, then the token which triggered this rule is -converted to a symbol and returned. A false @var{sop} argument to the -procedures prec:commentfix, prec:matchfix, or prec:inmatchfix has a -different meaning. - -@noindent -Character @var{tk} arguments will match only character tokens; -i.e. characters for which no token-group is assigned. Symbols and -strings will both match token strings; i.e. tokens resulting from token -groups. - -@defun prec:delim tk -Returns a rule specifying that @var{tk} should not be returned from -parsing; i.e. @var{tk}'s function is purely syntactic. The end-of-file -is always treated as a delimiter. -@end defun - -@defun prec:nofix tk sop -Returns a rule specifying the following actions take place when @var{tk} -is parsed: -@itemize @bullet -@item -If @var{sop} is a procedure, it is called with no arguments; the -resulting value is incorporated into the expression being built. -Otherwise, the list of @var{sop} is incorporated. -@end itemize -@end defun - -@defun prec:prefix tk sop bp rule1 @dots{} -Returns a rule specifying the following actions take place when @var{tk} -is parsed: -@itemize @bullet -@item -The rules @var{rule1} @dots{} augment and, in case of conflict, override -rules currently in effect. -@item -@code{prec:parse1} is called with binding-power @var{bp}. -@item -If @var{sop} is a procedure, it is called with the expression returned -from @code{prec:parse1}; the resulting value is incorporated into the -expression being built. Otherwise, the list of @var{sop} and the -expression returned from @code{prec:parse1} is incorporated. -@item -The ruleset in effect before @var{tk} was parsed is restored; -@var{rule1} @dots{} are forgotten. -@end itemize -@end defun - -@defun prec:infix tk sop lbp bp rule1 @dots{} -Returns a rule declaring the left-binding-precedence of the token -@var{tk} is @var{lbp} and specifying the following actions take place -when @var{tk} is parsed: -@itemize @bullet -@item -The rules @var{rule1} @dots{} augment and, in case of conflict, override -rules currently in effect. -@item -One expression is parsed with binding-power @var{lbp}. If instead a -delimiter is encountered, a warning is issued. -@item -If @var{sop} is a procedure, it is applied to the list of @var{left} and -the parsed expression; the resulting value is incorporated into the -expression being built. Otherwise, the list of @var{sop}, the -@var{left} expression, and the parsed expression is incorporated. -@item -The ruleset in effect before @var{tk} was parsed is restored; -@var{rule1} @dots{} are forgotten. -@end itemize -@end defun - -@defun prec:nary tk sop bp -Returns a rule declaring the left-binding-precedence of the token -@var{tk} is @var{bp} and specifying the following actions take place -when @var{tk} is parsed: -@itemize @bullet -@item -Expressions are parsed with binding-power @var{bp} as far as they are -interleaved with the token @var{tk}. -@item -If @var{sop} is a procedure, it is applied to the list of @var{left} and -the parsed expressions; the resulting value is incorporated into the -expression being built. Otherwise, the list of @var{sop}, the -@var{left} expression, and the parsed expressions is incorporated. -@end itemize -@end defun - -@defun prec:postfix tk sop lbp -Returns a rule declaring the left-binding-precedence of the token -@var{tk} is @var{lbp} and specifying the following actions take place -when @var{tk} is parsed: -@itemize @bullet -@item -If @var{sop} is a procedure, it is called with the @var{left} expression; -the resulting value is incorporated into the expression being built. -Otherwise, the list of @var{sop} and the @var{left} expression is -incorporated. -@end itemize -@end defun - -@defun prec:prestfix tk sop bp rule1 @dots{} -Returns a rule specifying the following actions take place when @var{tk} -is parsed: -@itemize @bullet -@item -The rules @var{rule1} @dots{} augment and, in case of conflict, override -rules currently in effect. -@item -Expressions are parsed with binding-power @var{bp} until a delimiter is -reached. -@item -If @var{sop} is a procedure, it is applied to the list of parsed -expressions; the resulting value is incorporated into the expression -being built. Otherwise, the list of @var{sop} and the parsed -expressions is incorporated. -@item -The ruleset in effect before @var{tk} was parsed is restored; -@var{rule1} @dots{} are forgotten. -@end itemize -@end defun - -@defun prec:commentfix tk stp match rule1 @dots{} -Returns rules specifying the following actions take place when @var{tk} -is parsed: -@itemize @bullet -@item -The rules @var{rule1} @dots{} augment and, in case of conflict, override -rules currently in effect. -@item -Characters are read until and end-of-file or a sequence of characters -is read which matches the @emph{string} @var{match}. -@item -If @var{stp} is a procedure, it is called with the string of all that -was read between the @var{tk} and @var{match} (exclusive). -@item -The ruleset in effect before @var{tk} was parsed is restored; -@var{rule1} @dots{} are forgotten. -@end itemize - -Parsing of commentfix syntax differs from the others in several ways. -It reads directly from input without tokenizing; It calls @var{stp} but -does not return its value; nay any value. I added the @var{stp} -argument so that comment text could be echoed. -@end defun - -@defun prec:matchfix tk sop sep match rule1 @dots{} -Returns a rule specifying the following actions take place when @var{tk} -is parsed: -@itemize @bullet -@item -The rules @var{rule1} @dots{} augment and, in case of conflict, override -rules currently in effect. -@item -A rule declaring the token @var{match} a delimiter takes effect. -@item -Expressions are parsed with binding-power @code{0} until the token -@var{match} is reached. If the token @var{sep} does not appear between -each pair of expressions parsed, a warning is issued. -@item -If @var{sop} is a procedure, it is applied to the list of parsed -expressions; the resulting value is incorporated into the expression -being built. Otherwise, the list of @var{sop} and the parsed -expressions is incorporated. -@item -The ruleset in effect before @var{tk} was parsed is restored; -@var{rule1} @dots{} are forgotten. -@end itemize -@end defun - -@defun prec:inmatchfix tk sop sep match lbp rule1 @dots{} -Returns a rule declaring the left-binding-precedence of the token -@var{tk} is @var{lbp} and specifying the following actions take place -when @var{tk} is parsed: -@itemize @bullet -@item -The rules @var{rule1} @dots{} augment and, in case of conflict, override -rules currently in effect. -@item -A rule declaring the token @var{match} a delimiter takes effect. -@item -Expressions are parsed with binding-power @code{0} until the token -@var{match} is reached. If the token @var{sep} does not appear between -each pair of expressions parsed, a warning is issued. -@item -If @var{sop} is a procedure, it is applied to the list of @var{left} and -the parsed expressions; the resulting value is incorporated into the -expression being built. Otherwise, the list of @var{sop}, the -@var{left} expression, and the parsed expressions is incorporated. -@item -The ruleset in effect before @var{tk} was parsed is restored; -@var{rule1} @dots{} are forgotten. -@end itemize -@end defun - - -@node Format, Standard Formatted I/O, Precedence Parsing, Textual Conversion Packages -@section Format (version 3.0) - -@code{(require 'format)} -@ftindex format - -@include fmtdoc.txi - -@node Standard Formatted I/O, Programs and Arguments, Format, Textual Conversion Packages -@section Standard Formatted I/O - -@menu -* Standard Formatted Output:: 'printf -* Standard Formatted Input:: 'scanf -@end menu - -@subsection stdio - -@code{(require 'stdio)} -@ftindex stdio - -@code{require}s @code{printf} and @code{scanf} and additionally defines -the symbols: - -@defvar stdin -Defined to be @code{(current-input-port)}. -@end defvar -@defvar stdout -Defined to be @code{(current-output-port)}. -@end defvar -@defvar stderr -Defined to be @code{(current-error-port)}. -@end defvar - - -@node Standard Formatted Output, Standard Formatted Input, Standard Formatted I/O, Standard Formatted I/O -@subsection Standard Formatted Output - -@code{(require 'printf)} -@ftindex printf - -@deffn Procedure printf format arg1 @dots{} -@deffnx Procedure fprintf port format arg1 @dots{} -@deffnx Procedure sprintf str format arg1 @dots{} -@deffnx Procedure sprintf #f format arg1 @dots{} -@deffnx Procedure sprintf k format arg1 @dots{} - -Each function converts, formats, and outputs its @var{arg1} @dots{} -arguments according to the control string @var{format} argument and -returns the number of characters output. - -@code{printf} sends its output to the port @code{(current-output-port)}. -@code{fprintf} sends its output to the port @var{port}. @code{sprintf} -@code{string-set!}s locations of the non-constant string argument -@var{str} to the output characters. - -Two extensions of @code{sprintf} return new strings. If the first -argument is @code{#f}, then the returned string's length is as many -characters as specified by the @var{format} and data; if the first -argument is a non-negative integer @var{k}, then the length of the -returned string is also bounded by @var{k}. - -The string @var{format} contains plain characters which are copied to -the output stream, and conversion specifications, each of which results -in fetching zero or more of the arguments @var{arg1} @dots{}. The -results are undefined if there are an insufficient number of arguments -for the format. If @var{format} is exhausted while some of the -@var{arg1} @dots{} arguments remain unused, the excess @var{arg1} -@dots{} arguments are ignored. - -The conversion specifications in a format string have the form: - -@example -% @r{[} @var{flags} @r{]} @r{[} @var{width} @r{]} @r{[} . @var{precision} @r{]} @r{[} @var{type} @r{]} @var{conversion} -@end example - -An output conversion specifications consist of an initial @samp{%} -character followed in sequence by: - -@itemize @bullet -@item -Zero or more @dfn{flag characters} that modify the normal behavior of -the conversion specification. - -@table @asis -@item @samp{-} -Left-justify the result in the field. Normally the result is -right-justified. - -@item @samp{+} -For the signed @samp{%d} and @samp{%i} conversions and all inexact -conversions, prefix a plus sign if the value is positive. - -@item @samp{ } -For the signed @samp{%d} and @samp{%i} conversions, if the result -doesn't start with a plus or minus sign, prefix it with a space -character instead. Since the @samp{+} flag ensures that the result -includes a sign, this flag is ignored if both are specified. - -@item @samp{#} -For inexact conversions, @samp{#} specifies that the result should -always include a decimal point, even if no digits follow it. For the -@samp{%g} and @samp{%G} conversions, this also forces trailing zeros -after the decimal point to be printed where they would otherwise be -elided. - -For the @samp{%o} conversion, force the leading digit to be @samp{0}, as -if by increasing the precision. For @samp{%x} or @samp{%X}, prefix a -leading @samp{0x} or @samp{0X} (respectively) to the result. This -doesn't do anything useful for the @samp{%d}, @samp{%i}, or @samp{%u} -conversions. Using this flag produces output which can be parsed by the -@code{scanf} functions with the @samp{%i} conversion (@pxref{Standard -Formatted Input}). - - -@item @samp{0} -Pad the field with zeros instead of spaces. The zeros are placed after -any indication of sign or base. This flag is ignored if the @samp{-} -flag is also specified, or if a precision is specified for an exact -converson. -@end table - -@item -An optional decimal integer specifying the @dfn{minimum field width}. -If the normal conversion produces fewer characters than this, the field -is padded (with spaces or zeros per the @samp{0} flag) to the specified -width. This is a @emph{minimum} width; if the normal conversion -produces more characters than this, the field is @emph{not} truncated. -@cindex minimum field width (@code{printf}) - -Alternatively, if the field width is @samp{*}, the next argument in the -argument list (before the actual value to be printed) is used as the -field width. The width value must be an integer. If the value is -negative it is as though the @samp{-} flag is set (see above) and the -absolute value is used as the field width. - -@item -An optional @dfn{precision} to specify the number of digits to be -written for numeric conversions and the maximum field width for string -conversions. The precision is specified by a period (@samp{.}) followed -optionally by a decimal integer (which defaults to zero if omitted). -@cindex precision (@code{printf}) - -Alternatively, if the precision is @samp{.*}, the next argument in the -argument list (before the actual value to be printed) is used as the -precision. The value must be an integer, and is ignored if negative. -If you specify @samp{*} for both the field width and precision, the -field width argument precedes the precision argument. The @samp{.*} -precision is an enhancement. C library versions may not accept this -syntax. - -For the @samp{%f}, @samp{%e}, and @samp{%E} conversions, the precision -specifies how many digits follow the decimal-point character. The -default precision is @code{6}. If the precision is explicitly @code{0}, -the decimal point character is suppressed. - -For the @samp{%g} and @samp{%G} conversions, the precision specifies how -many significant digits to print. Significant digits are the first -digit before the decimal point, and all the digits after it. If the -precision is @code{0} or not specified for @samp{%g} or @samp{%G}, it is -treated like a value of @code{1}. If the value being printed cannot be -expressed accurately in the specified number of digits, the value is -rounded to the nearest number that fits. - -For exact conversions, if a precision is supplied it specifies the -minimum number of digits to appear; leading zeros are produced if -necessary. If a precision is not supplied, the number is printed with -as many digits as necessary. Converting an exact @samp{0} with an -explicit precision of zero produces no characters. - -@item -An optional one of @samp{l}, @samp{h} or @samp{L}, which is ignored for -numeric conversions. It is an error to specify these modifiers for -non-numeric conversions. - -@item -A character that specifies the conversion to be applied. -@end itemize - -@subsubsection Exact Conversions - -@table @asis -@item @samp{d}, @samp{i} -Print an integer as a signed decimal number. @samp{%d} and @samp{%i} -are synonymous for output, but are different when used with @code{scanf} -for input (@pxref{Standard Formatted Input}). - -@item @samp{o} -Print an integer as an unsigned octal number. - -@item @samp{u} -Print an integer as an unsigned decimal number. - -@item @samp{x}, @samp{X} -Print an integer as an unsigned hexadecimal number. @samp{%x} prints -using the digits @samp{0123456789abcdef}. @samp{%X} prints using the -digits @samp{0123456789ABCDEF}. -@end table - -@subsubsection Inexact Conversions - -@table @asis -@item @samp{f} -Print a floating-point number in fixed-point notation. - -@item @samp{e}, @samp{E} -Print a floating-point number in exponential notation. @samp{%e} prints -@samp{e} between mantissa and exponont. @samp{%E} prints @samp{E} -between mantissa and exponont. - -@item @samp{g}, @samp{G} -Print a floating-point number in either fixed or exponential notation, -whichever is more appropriate for its magnitude. Unless an @samp{#} -flag has been supplied, trailing zeros after a decimal point will be -stripped off. @samp{%g} prints @samp{e} between mantissa and exponont. -@samp{%G} prints @samp{E} between mantissa and exponent. - -@item @samp{k}, @samp{K} -Print a number like @samp{%g}, except that an SI prefix is output after -the number, which is scaled accordingly. @samp{%K} outputs a space -between number and prefix, @samp{%k} does not. - -@end table - -@subsubsection Other Conversions -@table @asis -@item @samp{c} -Print a single character. The @samp{-} flag is the only one which can -be specified. It is an error to specify a precision. - -@item @samp{s} -Print a string. The @samp{-} flag is the only one which can be -specified. A precision specifies the maximum number of characters to -output; otherwise all characters in the string are output. - -@item @samp{a}, @samp{A} -Print a scheme expression. The @samp{-} flag left-justifies the output. -The @samp{#} flag specifies that strings and characters should be quoted -as by @code{write} (which can be read using @code{read}); otherwise, -output is as @code{display} prints. A precision specifies the maximum -number of characters to output; otherwise as many characters as needed -are output. - -@emph{Note:} @samp{%a} and @samp{%A} are SLIB extensions. - -@c @item @samp{p} -@c Print the value of a pointer. - -@c @item @samp{n} -@c Get the number of characters printed so far. See @ref{Other Output Conversions}. -@c Note that this conversion specification never produces any output. - -@c @item @samp{m} -@c Print the string corresponding to the value of @code{errno}. -@c (This is a GNU extension.) -@c @xref{Other Output Conversions}. - -@item @samp{%} -Print a literal @samp{%} character. No argument is consumed. It is an -error to specifiy flags, field width, precision, or type modifiers with -@samp{%%}. -@end table -@end deffn - - -@node Standard Formatted Input, , Standard Formatted Output, Standard Formatted I/O -@subsection Standard Formatted Input - -@code{(require 'scanf)} -@ftindex scanf - -@deffn Function scanf-read-list format -@deffnx Function scanf-read-list format port -@deffnx Function scanf-read-list format string -@end deffn - -@defmac scanf format arg1 @dots{} -@defmacx fscanf port format arg1 @dots{} -@defmacx sscanf str format arg1 @dots{} - -Each function reads characters, interpreting them according to the -control string @var{format} argument. - -@code{scanf-read-list} returns a list of the items specified as far as -the input matches @var{format}. @code{scanf}, @code{fscanf}, and -@code{sscanf} return the number of items successfully matched and -stored. @code{scanf}, @code{fscanf}, and @code{sscanf} also set the -location corresponding to @var{arg1} @dots{} using the methods: - -@table @asis -@item symbol -@code{set!} -@item car expression -@code{set-car!} -@item cdr expression -@code{set-cdr!} -@item vector-ref expression -@code{vector-set!} -@item substring expression -@code{substring-move-left!} -@end table - -The argument to a @code{substring} expression in @var{arg1} @dots{} must -be a non-constant string. Characters will be stored starting at the -position specified by the second argument to @code{substring}. The -number of characters stored will be limited by either the position -specified by the third argument to @code{substring} or the length of the -matched string, whichever is less. - -The control string, @var{format}, contains conversion specifications and -other characters used to direct interpretation of input sequences. The -control string contains: - -@itemize @bullet -@item White-space characters (blanks, tabs, newlines, or formfeeds) -that cause input to be read (and discarded) up to the next -non-white-space character. - -@item An ordinary character (not @samp{%}) that must match the next -character of the input stream. - -@item Conversion specifications, consisting of the character @samp{%}, an -optional assignment suppressing character @samp{*}, an optional -numerical maximum-field width, an optional @samp{l}, @samp{h} or -@samp{L} which is ignored, and a conversion code. - -@c @item The conversion specification can alternatively be prefixed by -@c the character sequence @samp{%n$} instead of the character @samp{%}, -@c where @var{n} is a decimal integer in the range. The @samp{%n$} -@c construction indicates that the value of the next input field should be -@c placed in the @var{n}th place in the return list, rather than to the next -@c unused one. The two forms of introducing a conversion specification, -@c @samp{%} and @samp{%n$}, must not be mixed within a single format string -@c with the following exception: Skip fields (see below) can be designated -@c as @samp{%*} or @samp{%n$*}. In the latter case, @var{n} is ignored. - -@end itemize - -Unless the specification contains the @samp{n} conversion character -(described below), a conversion specification directs the conversion of -the next input field. The result of a conversion specification is -returned in the position of the corresponding argument points, unless -@samp{*} indicates assignment suppression. Assignment suppression -provides a way to describe an input field to be skipped. An input field -is defined as a string of characters; it extends to the next -inappropriate character or until the field width, if specified, is -exhausted. - -@quotation -@emph{Note:} This specification of format strings differs from the -@cite{ANSI C} and @cite{POSIX} specifications. In SLIB, white space -before an input field is not skipped unless white space appears before -the conversion specification in the format string. In order to write -format strings which work identically with @cite{ANSI C} and SLIB, -prepend whitespace to all conversion specifications except @samp{[} and -@samp{c}. -@end quotation - -The conversion code indicates the interpretation of the input field; For -a suppressed field, no value is returned. The following conversion -codes are legal: - -@table @asis - -@item @samp{%} -A single % is expected in the input at this point; no value is returned. - -@item @samp{d}, @samp{D} -A decimal integer is expected. - -@item @samp{u}, @samp{U} -An unsigned decimal integer is expected. - -@item @samp{o}, @samp{O} -An octal integer is expected. - -@item @samp{x}, @samp{X} -A hexadecimal integer is expected. - -@item @samp{i} -An integer is expected. Returns the value of the next input item, -interpreted according to C conventions; a leading @samp{0} implies -octal, a leading @samp{0x} implies hexadecimal; otherwise, decimal is -assumed. - -@item @samp{n} -Returns the total number of bytes (including white space) read by -@code{scanf}. No input is consumed by @code{%n}. - -@item @samp{f}, @samp{F}, @samp{e}, @samp{E}, @samp{g}, @samp{G} -A floating-point number is expected. The input format for -floating-point numbers is an optionally signed string of digits, -possibly containing a radix character @samp{.}, followed by an optional -exponent field consisting of an @samp{E} or an @samp{e}, followed by an -optional @samp{+}, @samp{-}, or space, followed by an integer. - -@item @samp{c}, @samp{C} -@var{Width} characters are expected. The normal skip-over-white-space -is suppressed in this case; to read the next non-space character, use -@samp{%1s}. If a field width is given, a string is returned; up to the -indicated number of characters is read. - -@item @samp{s}, @samp{S} -A character string is expected The input field is terminated by a -white-space character. @code{scanf} cannot read a null string. - -@item @samp{[} -Indicates string data and the normal skip-over-leading-white-space is -suppressed. The left bracket is followed by a set of characters, called -the scanset, and a right bracket; the input field is the maximal -sequence of input characters consisting entirely of characters in the -scanset. @samp{^}, when it appears as the first character in the -scanset, serves as a complement operator and redefines the scanset as -the set of all characters not contained in the remainder of the scanset -string. Construction of the scanset follows certain conventions. A -range of characters may be represented by the construct first-last, -enabling @samp{[0123456789]} to be expressed @samp{[0-9]}. Using this -convention, first must be lexically less than or equal to last; -otherwise, the dash stands for itself. The dash also stands for itself -when it is the first or the last character in the scanset. To include -the right square bracket as an element of the scanset, it must appear as -the first character (possibly preceded by a @samp{^}) of the scanset, in -which case it will not be interpreted syntactically as the closing -bracket. At least one character must match for this conversion to -succeed. -@end table - -The @code{scanf} functions terminate their conversions at end-of-file, -at the end of the control string, or when an input character conflicts -with the control string. In the latter case, the offending character is -left unread in the input stream. -@end defmac - - -@node Programs and Arguments, HTML, Standard Formatted I/O, Textual Conversion Packages -@section Program and Arguments - -@menu -* Getopt:: Command Line option parsing -* Command Line:: A command line reader for Scheme shells -* Parameter lists:: 'parameters -* Getopt Parameter lists:: 'getopt-parameters -* Filenames:: 'glob or 'filename -* Batch:: 'batch -@end menu - -@node Getopt, Command Line, Programs and Arguments, Programs and Arguments -@subsection Getopt - -@code{(require 'getopt)} -@ftindex getopt - -This routine implements Posix command line argument parsing. Notice -that returning values through global variables means that @code{getopt} -is @emph{not} reentrant. - -@defvar *optind* -Is the index of the current element of the command line. It is -initially one. In order to parse a new command line or reparse an old -one, @var{*opting*} must be reset. -@end defvar - -@defvar *optarg* -Is set by getopt to the (string) option-argument of the current option. -@end defvar - -@deffn Procedure getopt argc argv optstring -Returns the next option letter in @var{argv} (starting from -@code{(vector-ref argv *optind*)}) that matches a letter in -@var{optstring}. @var{argv} is a vector or list of strings, the 0th of -which getopt usually ignores. @var{argc} is the argument count, usually -the length of @var{argv}. @var{optstring} is a string of recognized -option characters; if a character is followed by a colon, the option -takes an argument which may be immediately following it in the string or -in the next element of @var{argv}. - -@var{*optind*} is the index of the next element of the @var{argv} vector -to be processed. It is initialized to 1 by @file{getopt.scm}, and -@code{getopt} updates it when it finishes with each element of -@var{argv}. - -@code{getopt} returns the next option character from @var{argv} that -matches a character in @var{optstring}, if there is one that matches. -If the option takes an argument, @code{getopt} sets the variable -@var{*optarg*} to the option-argument as follows: - -@itemize @bullet -@item -If the option was the last character in the string pointed to by an -element of @var{argv}, then @var{*optarg*} contains the next element of -@var{argv}, and @var{*optind*} is incremented by 2. If the resulting -value of @var{*optind*} is greater than or equal to @var{argc}, this -indicates a missing option argument, and @code{getopt} returns an error -indication. - -@item -Otherwise, @var{*optarg*} is set to the string following the option -character in that element of @var{argv}, and @var{*optind*} is -incremented by 1. -@end itemize - -If, when @code{getopt} is called, the string @code{(vector-ref argv -*optind*)} either does not begin with the character @code{#\-} or is -just @code{"-"}, @code{getopt} returns @code{#f} without changing -@var{*optind*}. If @code{(vector-ref argv *optind*)} is the string -@code{"--"}, @code{getopt} returns @code{#f} after incrementing -@var{*optind*}. - -If @code{getopt} encounters an option character that is not contained in -@var{optstring}, it returns the question-mark @code{#\?} character. If -it detects a missing option argument, it returns the colon character -@code{#\:} if the first character of @var{optstring} was a colon, or a -question-mark character otherwise. In either case, @code{getopt} sets -the variable @var{getopt:opt} to the option character that caused the -error. - -The special option @code{"--"} can be used to delimit the end of the -options; @code{#f} is returned, and @code{"--"} is skipped. - -RETURN VALUE - -@code{getopt} returns the next option character specified on the command -line. A colon @code{#\:} is returned if @code{getopt} detects a missing -argument and the first character of @var{optstring} was a colon -@code{#\:}. - -A question-mark @code{#\?} is returned if @code{getopt} encounters an -option character not in @var{optstring} or detects a missing argument -and the first character of @var{optstring} was not a colon @code{#\:}. - -Otherwise, @code{getopt} returns @code{#f} when all command line options -have been parsed. - -Example: -@lisp -#! /usr/local/bin/scm -;;;This code is SCM specific. -(define argv (program-arguments)) -(require 'getopt) -@ftindex getopt - -(define opts ":a:b:cd") -(let loop ((opt (getopt (length argv) argv opts))) - (case opt - ((#\a) (print "option a: " *optarg*)) - ((#\b) (print "option b: " *optarg*)) - ((#\c) (print "option c")) - ((#\d) (print "option d")) - ((#\?) (print "error" getopt:opt)) - ((#\:) (print "missing arg" getopt:opt)) - ((#f) (if (< *optind* (length argv)) - (print "argv[" *optind* "]=" - (list-ref argv *optind*))) - (set! *optind* (+ *optind* 1)))) - (if (< *optind* (length argv)) - (loop (getopt (length argv) argv opts)))) - -(slib:exit) -@end lisp -@end deffn - -@subsection Getopt-- - -@defun getopt-- argc argv optstring -The procedure @code{getopt--} is an extended version of @code{getopt} -which parses @dfn{long option names} of the form -@samp{--hold-the-onions} and @samp{--verbosity-level=extreme}. -@w{@code{Getopt--}} behaves as @code{getopt} except for non-empty -options beginning with @samp{--}. - -Options beginning with @samp{--} are returned as strings rather than -characters. If a value is assigned (using @samp{=}) to a long option, -@code{*optarg*} is set to the value. The @samp{=} and value are -not returned as part of the option string. - -No information is passed to @code{getopt--} concerning which long -options should be accepted or whether such options can take arguments. -If a long option did not have an argument, @code{*optarg} will be set to -@code{#f}. The caller is responsible for detecting and reporting -errors. - -@example -(define opts ":-:b:") -(define argc 5) -(define argv '("foo" "-b9" "--f1" "--2=" "--g3=35234.342" "--")) -(define *optind* 1) -(define *optarg* #f) -(require 'qp) -@ftindex qp -(do ((i 5 (+ -1 i))) - ((zero? i)) - (define opt (getopt-- argc argv opts)) - (print *optind* opt *optarg*))) -@print{} -2 #\b "9" -3 "f1" #f -4 "2" "" -5 "g3" "35234.342" -5 #f "35234.342" -@end example -@end defun - -@node Command Line, Parameter lists, Getopt, Programs and Arguments -@subsection Command Line - -@code{(require 'read-command)} -@ftindex read-command - -@defun read-command port -@defunx read-command -@code{read-command} converts a @dfn{command line} into a list of strings -@cindex command line -suitable for parsing by @code{getopt}. The syntax of command lines -supported resembles that of popular @dfn{shell}s. @code{read-command} -updates @var{port} to point to the first character past the command -delimiter. - -If an end of file is encountered in the input before any characters are -found that can begin an object or comment, then an end of file object is -returned. - -The @var{port} argument may be omitted, in which case it defaults to the -value returned by @code{current-input-port}. - -The fields into which the command line is split are delimited by -whitespace as defined by @code{char-whitespace?}. The end of a command -is delimited by end-of-file or unescaped semicolon (@key{;}) or -@key{newline}. Any character can be literally included in a field by -escaping it with a backslach (@key{\}). - -The initial character and types of fields recognized are: -@table @asis -@item @samp{\} -The next character has is taken literally and not interpreted as a field -delimiter. If @key{\} is the last character before a @key{newline}, -that @key{newline} is just ignored. Processing continues from the -characters after the @key{newline} as though the backslash and -@key{newline} were not there. -@item @samp{"} -The characters up to the next unescaped @key{"} are taken literally, -according to [R4RS] rules for literal strings (@pxref{Strings, , ,r4rs, -Revised(4) Scheme}). -@item @samp{(}, @samp{%'} -One scheme expression is @code{read} starting with this character. The -@code{read} expression is evaluated, converted to a string -(using @code{display}), and replaces the expression in the returned -field. -@item @samp{;} -Semicolon delimits a command. Using semicolons more than one command -can appear on a line. Escaped semicolons and semicolons inside strings -do not delimit commands. -@end table - -@noindent -The comment field differs from the previous fields in that it must be -the first character of a command or appear after whitespace in order to -be recognized. @key{#} can be part of fields if these conditions are -not met. For instance, @code{ab#c} is just the field ab#c. - -@table @samp -@item # -Introduces a comment. The comment continues to the end of the line on -which the semicolon appears. Comments are treated as whitespace by -@code{read-dommand-line} and backslashes before @key{newline}s in -comments are also ignored. -@end table -@end defun - -@defun read-options-file filename -@code{read-options-file} converts an @dfn{options file} into a list of -@cindex options file -strings suitable for parsing by @code{getopt}. The syntax of options -files is the same as the syntax for command -lines, except that @key{newline}s do not terminate reading (only @key{;} -or end of file). - -If an end of file is encountered before any characters are found that -can begin an object or comment, then an end of file object is returned. -@end defun - - - -@node Parameter lists, Getopt Parameter lists, Command Line, Programs and Arguments -@subsection Parameter lists - -@code{(require 'parameters)} -@ftindex parameters - -@noindent -Arguments to procedures in scheme are distinguished from each other by -their position in the procedure call. This can be confusing when a -procedure takes many arguments, many of which are not often used. - -@noindent -A @dfn{parameter-list} is a way of passing named information to a -procedure. Procedures are also defined to set unused parameters to -default values, check parameters, and combine parameter lists. - -@noindent -A @var{parameter} has the form @code{(@r{parameter-name} @r{value1} -@dots{})}. This format allows for more than one value per -parameter-name. - -@noindent -A @var{parameter-list} is a list of @var{parameter}s, each with a -different @var{parameter-name}. - -@deffn Function make-parameter-list parameter-names -Returns an empty parameter-list with slots for @var{parameter-names}. -@end deffn - -@deffn Function parameter-list-ref parameter-list parameter-name -@var{parameter-name} must name a valid slot of @var{parameter-list}. -@code{parameter-list-ref} returns the value of parameter -@var{parameter-name} of @var{parameter-list}. -@end deffn - -@deffn Function remove-parameter parameter-name parameter-list -Removes the parameter @var{parameter-name} from @var{parameter-list}. -@code{remove-parameter} does not alter the argument -@var{parameter-list}. - -If there are more than one @var{parameter-name} parameters, an error is -signaled. -@end deffn - -@deffn Procedure adjoin-parameters! parameter-list parameter1 @dots{} -Returns @var{parameter-list} with @var{parameter1} @dots{} merged in. -@end deffn - -@deffn Procedure parameter-list-expand expanders parameter-list -@var{expanders} is a list of procedures whose order matches the order of -the @var{parameter-name}s in the call to @code{make-parameter-list} -which created @var{parameter-list}. For each non-false element of -@var{expanders} that procedure is mapped over the corresponding -parameter value and the returned parameter lists are merged into -@var{parameter-list}. - -This process is repeated until @var{parameter-list} stops growing. The -value returned from @code{parameter-list-expand} is unspecified. -@end deffn - -@deffn Function fill-empty-parameters defaulters parameter-list -@var{defaulters} is a list of procedures whose order matches the order -of the @var{parameter-name}s in the call to @code{make-parameter-list} -which created @var{parameter-list}. @code{fill-empty-parameters} -returns a new parameter-list with each empty parameter replaced with the -list returned by calling the corresponding @var{defaulter} with -@var{parameter-list} as its argument. -@end deffn - -@deffn Function check-parameters checks parameter-list -@var{checks} is a list of procedures whose order matches the order of -the @var{parameter-name}s in the call to @code{make-parameter-list} -which created @var{parameter-list}. - -@code{check-parameters} returns @var{parameter-list} if each @var{check} -of the corresponding @var{parameter-list} returns non-false. If some -@var{check} returns @code{#f} a warning is signaled. -@end deffn - -@noindent -In the following procedures @var{arities} is a list of symbols. The -elements of @code{arities} can be: - -@table @code -@item single -Requires a single parameter. -@item optional -A single parameter or no parameter is acceptable. -@item boolean -A single boolean parameter or zero parameters is acceptable. -@item nary -Any number of parameters are acceptable. -@item nary1 -One or more of parameters are acceptable. -@end table - -@deffn Function parameter-list->arglist positions arities parameter-list -Returns @var{parameter-list} converted to an argument list. Parameters -of @var{arity} type @code{single} and @code{boolean} are converted to -the single value associated with them. The other @var{arity} types are -converted to lists of the value(s). - -@var{positions} is a list of positive integers whose order matches the -order of the @var{parameter-name}s in the call to -@code{make-parameter-list} which created @var{parameter-list}. The -integers specify in which argument position the corresponding parameter -should appear. -@end deffn - - -@node Getopt Parameter lists, Filenames, Parameter lists, Programs and Arguments -@subsection Getopt Parameter lists - -@code{(require 'getopt-parameters)} - -@deffn Function getopt->parameter-list argc argv optnames arities types aliases desc @dots{} -Returns @var{argv} converted to a parameter-list. @var{optnames} are -the parameter-names. @var{arities} and @var{types} are lists of symbols -corresponding to @var{optnames}. - -@var{aliases} is a list of lists of strings or integers paired with -elements of @var{optnames}. Each one-character string will be treated -as a single @samp{-} option by @code{getopt}. Longer strings will be -treated as long-named options (@pxref{Getopt, getopt--}). - -If the @var{aliases} association list has only strings as its -@code{car}s, then all the option-arguments after an option (and before -the next option) are adjoined to that option. - -If the @var{aliases} association list has integers, then each (string) -option will take at most one option-argument. Unoptioned arguments are -collected in a list. A @samp{-1} alias will take the last argument in -this list; @samp{+1} will take the first argument in the list. The -aliases -2 then +2; -3 then +3; @dots{} are tried so long as a positive -or negative consecutive alias is found and arguments remain in the list. -Finally a @samp{0} alias, if found, absorbs any remaining arguments. - -In all cases, if unclaimed arguments remain after processing, a warning -is signaled and #f is returned. -@end deffn - -@deffn Function getopt->arglist argc argv optnames positions arities types defaulters checks aliases desc @dots{} -Like @code{getopt->parameter-list}, but converts @var{argv} to an -argument-list as specified by @var{optnames}, @var{positions}, -@var{arities}, @var{types}, @var{defaulters}, @var{checks}, and -@var{aliases}. If the options supplied violate the @var{arities} or -@var{checks} constraints, then a warning is signaled and #f is returned. -@end deffn - -@noindent -These @code{getopt} functions can be used with SLIB relational -databases. For an example, @xref{Database Utilities, -make-command-server}. - -@noindent -If errors are encountered while processing options, directions for using -the options (and argument strings @var{desc} @dots{}) are printed to -@code{current-error-port}. - -@example -(begin - (set! *optind* 1) - (getopt->parameter-list - 2 - '("cmd" "-?") - '(flag number symbols symbols string flag2 flag3 num2 num3) - '(boolean optional nary1 nary single boolean boolean nary nary) - '(boolean integer symbol symbol string boolean boolean integer integer) - '(("flag" flag) - ("f" flag) - ("Flag" flag2) - ("B" flag3) - ("optional" number) - ("o" number) - ("nary1" symbols) - ("N" symbols) - ("nary" symbols) - ("n" symbols) - ("single" string) - ("s" string) - ("a" num2) - ("Abs" num3)))) -@print{} -Usage: cmd [OPTION ARGUMENT ...] ... - - -f, --flag - -o, --optional= - -n, --nary= ... - -N, --nary1= ... - -s, --single= - --Flag - -B - -a ... - --Abs= ... - -ERROR: getopt->parameter-list "unrecognized option" "-?" -@end example - - -@node Filenames, Batch, Getopt Parameter lists, Programs and Arguments -@subsection Filenames - -@code{(require 'filename)} or @code{(require 'glob)} - -@defun filename:match?? pattern -@defunx filename:match-ci?? pattern -Returns a predicate which returns a non-false value if its string argument -matches (the string) @var{pattern}, false otherwise. Filename matching -is like -@cindex glob -@dfn{glob} expansion described the bash manpage, except that names -beginning with @samp{.} are matched and @samp{/} characters are not -treated specially. - -These functions interpret the following characters specially in -@var{pattern} strings: -@table @samp -@item * -Matches any string, including the null string. -@item ? -Matches any single character. -@item [@dots{}] -Matches any one of the enclosed characters. A pair of characters -separated by a minus sign (-) denotes a range; any character lexically -between those two characters, inclusive, is matched. If the first -character following the @samp{[} is a @samp{!} or a @samp{^} then any -character not enclosed is matched. A @samp{-} or @samp{]} may be -matched by including it as the first or last character in the set. -@end table - -@example -@end example -@end defun - -@defun filename:substitute?? pattern template -@defunx filename:substitute-ci?? pattern template -Returns a function transforming a single string argument according to -glob patterns @var{pattern} and @var{template}. @var{pattern} and -@var{template} must have the same number of wildcard specifications, -which need not be identical. @var{pattern} and @var{template} may have -a different number of literal sections. If an argument to the function -matches @var{pattern} in the sense of @code{filename:match??} then it -returns a copy of @var{template} in which each wildcard specification is -replaced by the part of the argument matched by the corresponding -wildcard specification in @var{pattern}. A @code{*} wildcard matches -the longest leftmost string possible. If the argument does not match -@var{pattern} then false is returned. - -@var{template} may be a function accepting the same number of string -arguments as there are wildcard specifications in @var{pattern}. In -the case of a match the result of applying @var{template} to a list -of the substrings matched by wildcard specifications will be returned, -otherwise @var{template} will not be called and @code{#f} will be returned. - -@example -((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm") - "scm_10.html") -@result{} "scm5c4_10.htm" -((filename:substitute?? "??" "beg?mid?end") "AZ") -@result{} "begAmidZend" -((filename:substitute?? "*na*" "?NA?") "banana") -@result{} "banaNA" -((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1))) "ABZ") -@result{} "ZA" -@end example -@end defun - -@defun replace-suffix str old new -@var{str} can be a string or a list of strings. Returns a new string -(or strings) similar to @code{str} but with the suffix string @var{old} -removed and the suffix string @var{new} appended. If the end of -@var{str} does not match @var{old}, an error is signaled. - -@example -(replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c") -@result{} "/usr/local/lib/slib/batch.c" -@end example -@end defun - - -@node Batch, , Filenames, Programs and Arguments -@subsection Batch - -@code{(require 'batch)} -@ftindex batch - -@noindent -The batch procedures provide a way to write and execute portable scripts -for a variety of operating systems. Each @code{batch:} procedure takes -as its first argument a parameter-list (@pxref{Parameter lists}). This -parameter-list argument @var{parms} contains named associations. Batch -currently uses 2 of these: - -@table @code -@item batch-port -The port on which to write lines of the batch file. -@item batch-dialect -The syntax of batch file to generate. Currently supported are: -@itemize @bullet -@item -unix -@item -dos -@item -vms -@item -amigados -@item -system -@item -*unknown* -@end itemize -@end table - -@noindent -@file{batch.scm} uses 2 enhanced relational tables (@pxref{Database -Utilities}) to store information linking the names of -@code{operating-system}s to @code{batch-dialect}es. - -@defun batch:initialize! database -Defines @code{operating-system} and @code{batch-dialect} tables and adds -the domain @code{operating-system} to the enhanced relational database -@var{database}. -@end defun - -@defvar batch:platform -Is batch's best guess as to which operating-system it is running under. -@code{batch:platform} is set to @code{(software-type)} -(@pxref{Configuration}) unless @code{(software-type)} is @code{unix}, -in which case finer distinctions are made. -@end defvar - -@defun batch:call-with-output-script parms file proc -@var{proc} should be a procedure of one argument. If @var{file} is an -output-port, @code{batch:call-with-output-script} writes an appropriate -header to @var{file} and then calls @var{proc} with @var{file} as the -only argument. If @var{file} is a string, -@code{batch:call-with-output-script} opens a output-file of name -@var{file}, writes an appropriate header to @var{file}, and then calls -@var{proc} with the newly opened port as the only argument. Otherwise, -@code{batch:call-with-output-script} acts as if it was called with the -result of @code{(current-output-port)} as its third argument. -@end defun - -@noindent -The rest of the @code{batch:} procedures write (or execute if -@code{batch-dialect} is @code{system}) commands to the batch port which -has been added to @var{parms} or @code{(copy-tree @var{parms})} by the -code: - -@example -(adjoin-parameters! @var{parms} (list 'batch-port @var{port})) -@end example - -@defun batch:command parms string1 string2 @dots{} -Calls @code{batch:try-command} (below) with arguments, but signals an -error if @code{batch:try-command} returns @code{#f}. -@end defun - -@noindent -These functions return a non-false value if the command was successfully -translated into the batch dialect and @code{#f} if not. In the case of -the @code{system} dialect, the value is non-false if the operation -suceeded. - -@defun batch:try-command parms string1 string2 @dots{} -Writes a command to the @code{batch-port} in @var{parms} which executes -the program named @var{string1} with arguments @var{string2} @dots{}. -@end defun - -@defun batch:try-chopped-command parms arg1 arg2 @dots{} list -breaks the last argument @var{list} into chunks small enough so that the -command: - -@example -@var{arg1} @var{arg2} @dots{} @var{chunk} -@end example - -fits withing the platform's maximum command-line length. - -@code{batch:try-chopped-command} calls @code{batch:try-command} with the -command and returns non-false only if the commands all fit and -@code{batch:try-command} of each command line returned non-false. -@end defun - -@defun batch:run-script parms string1 string2 @dots{} -Writes a command to the @code{batch-port} in @var{parms} which executes -the batch script named @var{string1} with arguments @var{string2} -@dots{}. - -@emph{Note:} @code{batch:run-script} and @code{batch:try-command} are not the -same for some operating systems (VMS). -@end defun - -@defun batch:comment parms line1 @dots{} -Writes comment lines @var{line1} @dots{} to the @code{batch-port} in -@var{parms}. -@end defun - -@defun batch:lines->file parms file line1 @dots{} -Writes commands to the @code{batch-port} in @var{parms} which create a -file named @var{file} with contents @var{line1} @dots{}. -@end defun - -@defun batch:delete-file parms file -Writes a command to the @code{batch-port} in @var{parms} which deletes -the file named @var{file}. -@end defun - -@defun batch:rename-file parms old-name new-name -Writes a command to the @code{batch-port} in @var{parms} which renames -the file @var{old-name} to @var{new-name}. -@end defun - -@noindent -In addition, batch provides some small utilities very useful for writing -scripts: - -@defun truncate-up-to path char -@defunx truncate-up-to path string -@defunx truncate-up-to path charlist -@var{path} can be a string or a list of strings. Returns @var{path} -sans any prefixes ending with a character of the second argument. This -can be used to derive a filename moved locally from elsewhere. - -@example -(truncate-up-to "/usr/local/lib/slib/batch.scm" "/") -@result{} "batch.scm" -@end example -@end defun - -@defun string-join joiner string1 @dots{} -Returns a new string consisting of all the strings @var{string1} @dots{} -in order appended together with the string @var{joiner} between each -adjacent pair. -@end defun - -@defun must-be-first list1 list2 -Returns a new list consisting of the elements of @var{list2} ordered so -that if some elements of @var{list1} are @code{equal?} to elements of -@var{list2}, then those elements will appear first and in the order of -@var{list1}. -@end defun - -@defun must-be-last list1 list2 -Returns a new list consisting of the elements of @var{list1} ordered so -that if some elements of @var{list2} are @code{equal?} to elements of -@var{list1}, then those elements will appear last and in the order of -@var{list2}. -@end defun - -@defun os->batch-dialect osname -Returns its best guess for the @code{batch-dialect} to be used for the -operating-system named @var{osname}. @code{os->batch-dialect} uses the -tables added to @var{database} by @code{batch:initialize!}. -@end defun - -@noindent -Here is an example of the use of most of batch's procedures: - -@example -(require 'database-utilities) -@ftindex database-utilities -(require 'parameters) -@ftindex parameters -(require 'batch) -@ftindex batch -(require 'glob) -@ftindex glob - -(define batch (create-database #f 'alist-table)) -(batch:initialize! batch) - -(define my-parameters - (list (list 'batch-dialect (os->batch-dialect batch:platform)) - (list 'platform batch:platform) - (list 'batch-port (current-output-port)))) ;gets filled in later - -(batch:call-with-output-script - my-parameters - "my-batch" - (lambda (batch-port) - (adjoin-parameters! my-parameters (list 'batch-port batch-port)) - (and - (batch:comment my-parameters - "================ Write file with C program.") - (batch:rename-file my-parameters "hello.c" "hello.c~") - (batch:lines->file my-parameters "hello.c" - "#include " - "int main(int argc, char **argv)" - "@{" - " printf(\"hello world\\n\");" - " return 0;" - "@}" ) - (batch:command my-parameters "cc" "-c" "hello.c") - (batch:command my-parameters "cc" "-o" "hello" - (replace-suffix "hello.c" ".c" ".o")) - (batch:command my-parameters "hello") - (batch:delete-file my-parameters "hello") - (batch:delete-file my-parameters "hello.c") - (batch:delete-file my-parameters "hello.o") - (batch:delete-file my-parameters "my-batch") - ))) -@end example - -@noindent -Produces the file @file{my-batch}: - -@example -#!/bin/sh -# "my-batch" script created by SLIB/batch Sun Oct 31 18:24:10 1999 -# ================ Write file with C program. -mv -f hello.c hello.c~ -rm -f hello.c -echo '#include '>>hello.c -echo 'int main(int argc, char **argv)'>>hello.c -echo '@{'>>hello.c -echo ' printf("hello world\n");'>>hello.c -echo ' return 0;'>>hello.c -echo '@}'>>hello.c -cc -c hello.c -cc -o hello hello.o -hello -rm -f hello -rm -f hello.c -rm -f hello.o -rm -f my-batch -@end example - -@noindent -When run, @file{my-batch} prints: - -@example -bash$ my-batch -mv: hello.c: No such file or directory -hello world -@end example - - -@node HTML, HTML Tables, Programs and Arguments, Textual Conversion Packages -@section HTML - -@include htmlform.txi - - -@node HTML Tables, HTTP and CGI, HTML, Textual Conversion Packages -@section HTML Tables - -@include db2html.txi - - -@node HTTP and CGI, URI, HTML Tables, Textual Conversion Packages -@section HTTP and CGI - -@include http-cgi.txi - - -@node URI, Printing Scheme, HTTP and CGI, Textual Conversion Packages -@section URI - -@include uri.txi - - - -@node Printing Scheme, Time and Date, URI, Textual Conversion Packages -@section Printing Scheme - -@menu -* Generic-Write:: 'generic-write -* Object-To-String:: 'object->string -* Pretty-Print:: 'pretty-print, 'pprint-file -@end menu - - -@node Generic-Write, Object-To-String, Printing Scheme, Printing Scheme -@subsection Generic-Write - -@code{(require 'generic-write)} -@ftindex generic-write - -@code{generic-write} is a procedure that transforms a Scheme data value -(or Scheme program expression) into its textual representation and -prints it. The interface to the procedure is sufficiently general to -easily implement other useful formatting procedures such as pretty -printing, output to a string and truncated output. - -@deffn Procedure generic-write obj display? width output -@table @var -@item obj -Scheme data value to transform. -@item display? -Boolean, controls whether characters and strings are quoted. -@item width -Extended boolean, selects format: -@table @asis -@item #f -single line format -@item integer > 0 -pretty-print (value = max nb of chars per line) -@end table -@item output -Procedure of 1 argument of string type, called repeatedly with -successive substrings of the textual representation. This procedure can -return @code{#f} to stop the transformation. -@end table - -The value returned by @code{generic-write} is undefined. - -Examples: -@lisp -(write obj) @equiv{} (generic-write obj #f #f @var{display-string}) -(display obj) @equiv{} (generic-write obj #t #f @var{display-string}) -@end lisp -@noindent -where -@lisp -@var{display-string} @equiv{} -(lambda (s) (for-each write-char (string->list s)) #t) -@end lisp -@end deffn - - - -@node Object-To-String, Pretty-Print, Generic-Write, Printing Scheme -@subsection Object-To-String - -@code{(require 'object->string)} -@ftindex object->string - -@include obj2str.txi - - -@node Pretty-Print, , Object-To-String, Printing Scheme -@subsection Pretty-Print - -@code{(require 'pretty-print)} -@ftindex pretty-print - -@deffn Procedure pretty-print obj -@deffnx Procedure pretty-print obj port - -@code{pretty-print}s @var{obj} on @var{port}. If @var{port} is not -specified, @code{current-output-port} is used. - -Example: -@example -@group -(pretty-print '((1 2 3 4 5) (6 7 8 9 10) (11 12 13 14 15) - (16 17 18 19 20) (21 22 23 24 25))) - @print{} ((1 2 3 4 5) - @print{} (6 7 8 9 10) - @print{} (11 12 13 14 15) - @print{} (16 17 18 19 20) - @print{} (21 22 23 24 25)) -@end group -@end example -@end deffn - -@deffn Procedure pretty-print->string obj -@deffnx Procedure pretty-print->string obj width - -Returns the string of @var{obj} @code{pretty-print}ed in @var{width} -columns. If @var{width} is not specified, @code{(output-port-width)} is -used. - -Example: -@example -@group -(pretty-print->string '((1 2 3 4 5) (6 7 8 9 10) (11 12 13 14 15) - (16 17 18 19 20) (21 22 23 24 25))) -@result{} -"((1 2 3 4 5) - (6 7 8 9 10) - (11 12 13 14 15) - (16 17 18 19 20) - (21 22 23 24 25)) -" -@end group -@group -(pretty-print->string '((1 2 3 4 5) (6 7 8 9 10) (11 12 13 14 15) - (16 17 18 19 20) (21 22 23 24 25)) - 16) -@result{} -"((1 2 3 4 5) - (6 7 8 9 10) - (11 - 12 - 13 - 14 - 15) - (16 - 17 - 18 - 19 - 20) - (21 - 22 - 23 - 24 - 25)) -" -@end group -@end example -@end deffn - - -@code{(require 'pprint-file)} -@ftindex pprint-file - -@deffn Procedure pprint-file infile -@deffnx Procedure pprint-file infile outfile -Pretty-prints all the code in @var{infile}. If @var{outfile} is -specified, the output goes to @var{outfile}, otherwise it goes to -@code{(current-output-port)}. -@end deffn - -@defun pprint-filter-file infile proc outfile -@defunx pprint-filter-file infile proc -@var{infile} is a port or a string naming an existing file. Scheme -source code expressions and definitions are read from the port (or file) -and @var{proc} is applied to them sequentially. - -@var{outfile} is a port or a string. If no @var{outfile} is specified -then @code{current-output-port} is assumed. These expanded expressions -are then @code{pretty-print}ed to this port. - -Whitepsace and comments (introduced by @code{;}) which are not part of -scheme expressions are reproduced in the output. This procedure does -not affect the values returned by @code{current-input-port} and -@code{current-output-port}. -@end defun - -@code{pprint-filter-file} can be used to pre-compile macro-expansion and -thus can reduce loading time. The following will write into -@file{exp-code.scm} the result of expanding all defmacros in -@file{code.scm}. -@lisp -(require 'pprint-file) -@ftindex pprint-file -(require 'defmacroexpand) -@ftindex defmacroexpand -(defmacro:load "my-macros.scm") -(pprint-filter-file "code.scm" defmacro:expand* "exp-code.scm") -@end lisp - -@node Time and Date, Vector Graphics, Printing Scheme, Textual Conversion Packages -@section Time and Date - -@menu -* Time Zone:: -* Posix Time:: 'posix-time -* Common-Lisp Time:: 'common-lisp-time -@end menu - -@noindent -If @code{(provided? 'current-time)}: - -@noindent -The procedures @code{current-time}, @code{difftime}, and -@code{offset-time} deal with a @dfn{calendar time} datatype -@cindex time -@cindex calendar time -which may or may not be disjoint from other Scheme datatypes. - -@defun current-time -Returns the time since 00:00:00 GMT, January 1, 1970, measured in -seconds. Note that the reference time is different from the reference -time for @code{get-universal-time} in @ref{Common-Lisp Time}. -@end defun - -@defun difftime caltime1 caltime0 -Returns the difference (number of seconds) between twe calendar times: -@var{caltime1} - @var{caltime0}. @var{caltime0} may also be a number. -@end defun - -@defun offset-time caltime offset -Returns the calendar time of @var{caltime} offset by @var{offset} number -of seconds @code{(+ caltime offset)}. -@end defun - -@node Time Zone, Posix Time, Time and Date, Time and Date -@subsection Time Zone - -(require 'time-zone) - -@deftp {Data Format} TZ-string - -POSIX standards specify several formats for encoding time-zone rules. - -@table @t -@item :@i{} -If the first character of @i{} is @samp{/}, then -@i{} specifies the absolute pathname of a tzfile(5) format -time-zone file. Otherwise, @i{} is interpreted as a pathname -within @var{tzfile:vicinity} (/usr/lib/zoneinfo/) naming a tzfile(5) -format time-zone file. -@item @i{}@i{} -The string @i{} consists of 3 or more alphabetic characters. -@i{} specifies the time difference from GMT. The @i{} -is positive if the local time zone is west of the Prime Meridian and -negative if it is east. @i{} can be the number of hours or -hours and minutes (and optionally seconds) separated by @samp{:}. For -example, @code{-4:30}. -@item @i{}@i{}@i{} -@i{} is the at least 3 alphabetic characters naming the local -daylight-savings-time. -@item @i{}@i{}@i{}@i{} -@i{} specifies the offset from the Prime Meridian when -daylight-savings-time is in effect. -@end table - -The non-tzfile formats can optionally be followed by transition times -specifying the day and time when a zone changes from standard to -daylight-savings and back again. - -@table @t -@item ,@i{}/@i{