From 9ddacf866c266685c94638b1fa13ac129670d18e Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sat, 14 Apr 2001 11:24:45 +0000 Subject: [PATCH] Import SLIB 2d1. --- 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/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 + 165 files changed, 61896 insertions(+) create mode 100644 module/slib/ANNOUNCE create mode 100644 module/slib/Bev2slib.scm create mode 100644 module/slib/ChangeLog create mode 100644 module/slib/DrScheme.init create mode 100644 module/slib/FAQ create mode 100644 module/slib/Makefile create mode 100644 module/slib/README create mode 100644 module/slib/RScheme.init create mode 100644 module/slib/STk.init create mode 100644 module/slib/Template.scm create mode 100644 module/slib/alist.scm create mode 100644 module/slib/alistab.scm create mode 100644 module/slib/array.scm create mode 100644 module/slib/arraymap.scm create mode 100644 module/slib/batch.scm create mode 100644 module/slib/bigloo.init create mode 100644 module/slib/break.scm create mode 100644 module/slib/byte.scm create mode 100644 module/slib/chap.scm create mode 100644 module/slib/charplot.scm create mode 100644 module/slib/chez.init create mode 100644 module/slib/cltime.scm create mode 100644 module/slib/coerce.scm create mode 100644 module/slib/coerce.txi create mode 100644 module/slib/collect.scm create mode 100644 module/slib/comlist.scm create mode 100644 module/slib/comparse.scm create mode 100644 module/slib/cring.scm create mode 100644 module/slib/db2html.scm create mode 100644 module/slib/db2html.txi create mode 100644 module/slib/dbrowse.scm create mode 100644 module/slib/dbutil.scm create mode 100644 module/slib/debug.scm create mode 100644 module/slib/defmacex.scm create mode 100644 module/slib/determ.scm create mode 100644 module/slib/dwindtst.scm create mode 100644 module/slib/dynamic.scm create mode 100644 module/slib/dynwind.scm create mode 100644 module/slib/elk.init create mode 100644 module/slib/eval.scm create mode 100644 module/slib/factor.scm create mode 100644 module/slib/factor.txi create mode 100644 module/slib/fft.scm create mode 100644 module/slib/fluidlet.scm create mode 100644 module/slib/fmtdoc.txi create mode 100644 module/slib/format.scm create mode 100644 module/slib/formatst.scm create mode 100644 module/slib/gambit.init create mode 100644 module/slib/genwrite.scm create mode 100644 module/slib/getopt.scm create mode 100644 module/slib/getparam.scm create mode 100644 module/slib/glob.scm create mode 100644 module/slib/hash.scm create mode 100644 module/slib/hashtab.scm create mode 100644 module/slib/htmlform.scm create mode 100644 module/slib/htmlform.txi create mode 100644 module/slib/http-cgi.scm create mode 100644 module/slib/http-cgi.txi create mode 100644 module/slib/lineio.scm create mode 100644 module/slib/lineio.txi create mode 100644 module/slib/logical.scm create mode 100644 module/slib/macrotst.scm create mode 100644 module/slib/macscheme.init create mode 100644 module/slib/macwork.scm create mode 100644 module/slib/makcrc.scm create mode 100644 module/slib/mbe.scm create mode 100644 module/slib/minimize.scm create mode 100644 module/slib/minimize.txi create mode 100644 module/slib/mitcomp.pat create mode 100644 module/slib/mitscheme.init create mode 100644 module/slib/mklibcat.scm create mode 100644 module/slib/modular.scm create mode 100644 module/slib/mulapply.scm create mode 100644 module/slib/mularg.scm create mode 100644 module/slib/mwdenote.scm create mode 100644 module/slib/mwexpand.scm create mode 100644 module/slib/mwsynrul.scm create mode 100644 module/slib/nclients.scm create mode 100644 module/slib/nclients.txi create mode 100644 module/slib/obj2str.scm create mode 100644 module/slib/obj2str.txi create mode 100644 module/slib/objdoc.txi create mode 100644 module/slib/object.scm create mode 100644 module/slib/paramlst.scm create mode 100644 module/slib/plottest.scm create mode 100644 module/slib/pnm.scm create mode 100644 module/slib/pp.scm create mode 100644 module/slib/ppfile.scm create mode 100644 module/slib/prec.scm create mode 100644 module/slib/printf.scm create mode 100644 module/slib/priorque.scm create mode 100644 module/slib/process.scm create mode 100644 module/slib/promise.scm create mode 100644 module/slib/pscheme.init create mode 100644 module/slib/psxtime.scm create mode 100644 module/slib/qp.scm create mode 100644 module/slib/queue.scm create mode 100644 module/slib/r4rsyn.scm create mode 100644 module/slib/randinex.scm create mode 100644 module/slib/randinex.txi create mode 100644 module/slib/random.scm create mode 100644 module/slib/random.txi create mode 100644 module/slib/ratize.scm create mode 100644 module/slib/rdms.scm create mode 100644 module/slib/recobj.scm create mode 100644 module/slib/record.scm create mode 100644 module/slib/repl.scm create mode 100644 module/slib/report.scm create mode 100644 module/slib/require.scm create mode 100644 module/slib/root.scm create mode 100644 module/slib/sc2.scm create mode 100644 module/slib/sc4opt.scm create mode 100644 module/slib/sc4sc3.scm create mode 100644 module/slib/scaexpp.scm create mode 100644 module/slib/scaglob.scm create mode 100644 module/slib/scainit.scm create mode 100644 module/slib/scamacr.scm create mode 100644 module/slib/scanf.scm create mode 100644 module/slib/scaoutp.scm create mode 100644 module/slib/scheme2c.init create mode 100644 module/slib/scheme48.init create mode 100644 module/slib/schmooz.scm create mode 100644 module/slib/schmooz.texi create mode 100644 module/slib/scm.init create mode 100644 module/slib/scmacro.scm create mode 100644 module/slib/scmactst.scm create mode 100644 module/slib/scsh.init create mode 100644 module/slib/selfset.scm create mode 100644 module/slib/sierpinski.scm create mode 100644 module/slib/simetrix.scm create mode 100644 module/slib/slib.info create mode 100644 module/slib/slib.spec create mode 100644 module/slib/slib.texi create mode 100644 module/slib/sort.scm create mode 100644 module/slib/soundex.scm create mode 100644 module/slib/stdio.scm create mode 100644 module/slib/strcase.scm create mode 100644 module/slib/strport.scm create mode 100644 module/slib/strsrch.scm create mode 100644 module/slib/struct.scm create mode 100644 module/slib/structst.scm create mode 100644 module/slib/structure.scm create mode 100644 module/slib/syncase.sh create mode 100644 module/slib/synchk.scm create mode 100644 module/slib/synclo.scm create mode 100644 module/slib/synrul.scm create mode 100644 module/slib/t3.init create mode 100644 module/slib/tek40.scm create mode 100644 module/slib/tek41.scm create mode 100644 module/slib/timezone.scm create mode 100644 module/slib/trace.scm create mode 100644 module/slib/tree.scm create mode 100644 module/slib/trnscrpt.scm create mode 100644 module/slib/tsort.scm create mode 100644 module/slib/tzfile.scm create mode 100644 module/slib/umbscheme.init create mode 100644 module/slib/uri.scm create mode 100644 module/slib/uri.txi create mode 100644 module/slib/values.scm create mode 100644 module/slib/version.txi create mode 100644 module/slib/vscm.init create mode 100644 module/slib/withfile.scm create mode 100644 module/slib/wttest.scm create mode 100644 module/slib/wttree.scm create mode 100644 module/slib/yasyn.scm diff --git a/module/slib/ANNOUNCE b/module/slib/ANNOUNCE new file mode 100644 index 000000000..d8a00b585 --- /dev/null +++ b/module/slib/ANNOUNCE @@ -0,0 +1,171 @@ +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 new file mode 100644 index 000000000..24a7c68f6 --- /dev/null +++ b/module/slib/Bev2slib.scm @@ -0,0 +1,94 @@ +;;;; "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 new file mode 100644 index 000000000..9c71f1f47 --- /dev/null +++ b/module/slib/ChangeLog @@ -0,0 +1,2604 @@ +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 new file mode 100644 index 000000000..067625091 --- /dev/null +++ b/module/slib/DrScheme.init @@ -0,0 +1,6 @@ +;;;"DrScheme.init" Initialization for SLIB for DrScheme -*-scheme-*- +;; Friedrich Dominicus +;; Newsgroups: comp.lang.scheme +;; Date: 02 Oct 2000 09:24:57 +0200 + +(require-library "init.ss" "slibinit") diff --git a/module/slib/FAQ b/module/slib/FAQ new file mode 100644 index 000000000..8b8a63648 --- /dev/null +++ b/module/slib/FAQ @@ -0,0 +1,217 @@ +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 new file mode 100644 index 000000000..023e0ef55 --- /dev/null +++ b/module/slib/Makefile @@ -0,0 +1,333 @@ +# 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 new file mode 100644 index 000000000..4b55b610c --- /dev/null +++ b/module/slib/README @@ -0,0 +1,297 @@ +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 new file mode 100644 index 000000000..15b89b300 --- /dev/null +++ b/module/slib/RScheme.init @@ -0,0 +1,290 @@ +;;;"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 new file mode 100644 index 000000000..26ab01c61 --- /dev/null +++ b/module/slib/STk.init @@ -0,0 +1,256 @@ +;;;"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 new file mode 100644 index 000000000..aa8862718 --- /dev/null +++ b/module/slib/Template.scm @@ -0,0 +1,282 @@ +;;; "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 new file mode 100644 index 000000000..65ddb220c --- /dev/null +++ b/module/slib/alist.scm @@ -0,0 +1,66 @@ +;;;"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 new file mode 100644 index 000000000..395bf0678 --- /dev/null +++ b/module/slib/alistab.scm @@ -0,0 +1,352 @@ +;;; "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 new file mode 100644 index 000000000..08b8114bc --- /dev/null +++ b/module/slib/array.scm @@ -0,0 +1,279 @@ +;;;;"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 new file mode 100644 index 000000000..ab3d7c835 --- /dev/null +++ b/module/slib/arraymap.scm @@ -0,0 +1,78 @@ +;;;; "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 new file mode 100644 index 000000000..d77519dcb --- /dev/null +++ b/module/slib/batch.scm @@ -0,0 +1,454 @@ +;;; "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 new file mode 100644 index 000000000..211979b86 --- /dev/null +++ b/module/slib/bigloo.init @@ -0,0 +1,263 @@ +;; "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 new file mode 100644 index 000000000..ae92d407d --- /dev/null +++ b/module/slib/break.scm @@ -0,0 +1,149 @@ +;;;; "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 new file mode 100644 index 000000000..b34816da5 --- /dev/null +++ b/module/slib/byte.scm @@ -0,0 +1,15 @@ +;;; "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 new file mode 100644 index 000000000..6a20aebf3 --- /dev/null +++ b/module/slib/chap.scm @@ -0,0 +1,150 @@ +;;;; "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 new file mode 100644 index 000000000..d5cdbb539 --- /dev/null +++ b/module/slib/chez.init @@ -0,0 +1,396 @@ +;;;"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 new file mode 100644 index 000000000..441e7f985 --- /dev/null +++ b/module/slib/cltime.scm @@ -0,0 +1,67 @@ +;;;; "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 new file mode 100644 index 000000000..b2e58a770 --- /dev/null +++ b/module/slib/coerce.scm @@ -0,0 +1,107 @@ +;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF. +; Copyright (C) 1995, 2001 Aubrey Jaffer. +; +;Permission to copy this software, to 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 new file mode 100644 index 000000000..4b7f6b0ad --- /dev/null +++ b/module/slib/coerce.txi @@ -0,0 +1,12 @@ + +@defun type-of obj + +Returns a symbol name for the type of @var{obj}. +@end defun + +@defun coerce obj result-type + +Converts and returns @var{obj} of type @code{char}, @code{number}, +@code{string}, @code{symbol}, @code{list}, or @code{vector} to +@var{result-type} (which must be one of these symbols). +@end defun diff --git a/module/slib/collect.scm b/module/slib/collect.scm new file mode 100644 index 000000000..35a333d4e --- /dev/null +++ b/module/slib/collect.scm @@ -0,0 +1,236 @@ +;"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 new file mode 100644 index 000000000..bea99a70a --- /dev/null +++ b/module/slib/comlist.scm @@ -0,0 +1,328 @@ +;;"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 new file mode 100644 index 000000000..9066e36a7 --- /dev/null +++ b/module/slib/comparse.scm @@ -0,0 +1,99 @@ +;;; "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 new file mode 100644 index 000000000..320b1d2d5 --- /dev/null +++ b/module/slib/cring.scm @@ -0,0 +1,470 @@ +;;;"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 new file mode 100644 index 000000000..abfbc7326 --- /dev/null +++ b/module/slib/db2html.scm @@ -0,0 +1,463 @@ +;"db2html.scm" Convert relational database to hyperlinked pages. +; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer +; +;Permission to copy this software, to 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 new file mode 100644 index 000000000..0acdd46cf --- /dev/null +++ b/module/slib/db2html.txi @@ -0,0 +1,185 @@ +@code{(require 'db->html)} + + +@defun html:table options row @dots{} + +@end defun + +@defun html:caption caption align + + +@defunx html:caption caption +@var{align} can be @samp{top} or @samp{bottom}. +@end defun + +@defun html:heading columns +Outputs a heading row for the currently-started table. +@end defun + +@defun html:href-heading columns uris +Outputs a heading row with column-names @var{columns} linked to URIs @var{uris}. +@end defun + +@defun html:linked-row-converter k foreigns + + +The positive integer @var{k} is the primary-key-limit (number of +primary-keys) of the table. @var{foreigns} is a list of the filenames of +foreign-key field pages and #f for non foreign-key fields. + +@code{html:linked-row-converter} returns a procedure taking a row for its single argument. This +returned procedure returns the html string for that table row. +@end defun + +@defun table-name->filename table-name + +Returns the symbol @var{table-name} converted to a filename. +@end defun + +@defun table->linked-html caption db table-name match-key1 @dots{} + +Returns HTML string for @var{db} table @var{table-name}. Every foreign-key value is +linked to the page (of the table) defining that key. + +The optional @var{match-key1} @dots{} arguments restrict actions to a subset of +the table. @xref{Table Operations, match-key}. +@end defun + +@defun table->linked-page db table-name index-filename arg @dots{} + +Returns a complete HTML page. The string @var{index-filename} names the page which +refers to this one. + +The optional @var{args} @dots{} arguments restrict actions to a subset of +the table. @xref{Table Operations, match-key}. +@end defun + +@defun catalog->html db caption arg @dots{} + +Returns HTML string for the catalog table of @var{db}. +@end defun +@subsection HTML editing tables + +@noindent A client can modify one row of an editable table at a time. +For any change submitted, these routines check if that row has been +modified during the time the user has been editing the form. If so, +an error page results. + +@noindent The behavior of edited rows is: + +@itemize @bullet +@item +If no fields are changed, then no change is made to the table. +@item +If the primary keys equal null-keys (parameter defaults), and no other +user has modified that row, then that row is deleted. +@item +If only primary keys are changed, there are non-key fields, and no +row with the new keys is in the table, then the old row is +deleted and one with the new keys is inserted. +@item +If only non-key fields are changed, and that row has not been +modified by another user, then the row is changed to reflect the +fields. +@item +If both keys and non-key fields are changed, and no row with the +new keys is in the table, then a row is created with the new +keys and fields. +@item +If fields are changed, all fields are primary keys, and no row with +the new keys is in the table, then a row is created with the new +keys. +@end itemize + +@noindent After any change to the table, a @code{sync-database} of the +database is performed. + + +@defun command:modify-table table-name null-keys update delete retrieve + + +@defunx command:modify-table table-name null-keys update delete + +@defunx command:modify-table table-name null-keys update + +@defunx command:modify-table table-name null-keys + +Returns procedure (of @var{db}) which returns procedure to modify row +of @var{table-name}. @var{null-keys} is the list of @dfn{null} keys which indicate that the row +@cindex null +is to be deleted. Optional arguments @var{update}, @var{delete}, and @var{retrieve} default to the +@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @var{table-name} in +@var{db}. +@end defun + +@defun command:make-editable-table rdb table-name arg @dots{} +Given @var{table-name} in @var{rdb}, creates parameter and @code{*command*} tables +for editing one row of @var{table-name} at a time. @code{command:make-editable-table} returns a procedure taking a +row argument which returns the HTML string for editing that row. + +Optional @var{args} are expressions (lists) added to the call to +@code{command:modify-table}. + +The domain name of a column determines the expected arity of the data +stored in that column. Domain names ending in: + +@table @samp +@item * +have arity @samp{nary}; +@item + +have arity @samp{nary1}. +@end table +@end defun + +@defun html:editable-row-converter k names edit-point edit-converter + + +The positive integer @var{k} is the primary-key-limit (number of +primary-keys) of the table. @var{names} is a list of the field-names. @var{edit-point} is +the list of primary-keys denoting the row to edit (or #f). @var{edit-converter} is the +procedure called with @var{k}, @var{names}, and the row to edit. + +@code{html:editable-row-converter} returns a procedure taking a row for its single argument. This +returned procedure returns the html string for that table row. + +Each HTML table constructed using @code{html:editable-row-converter} has first @var{k} fields (typically +the primary key fields) of each row linked to a text encoding of these +fields (the result of calling @code{row->anchor}). The page so +referenced typically allows the user to edit fields of that row. +@end defun +@subsection HTML databases + + +@defun db->html-files db dir index-filename caption +@var{db} must be a relational database. @var{dir} must be #f or a +non-empty string naming an existing sub-directory of the current +directory. + +@code{db->html-files} creates an html page for each table in the database @var{db} in the +sub-directory named @var{dir}, or the current directory if @var{dir} is #f. The +top level page with the catalog of tables (captioned @var{caption}) is written +to a file named @var{index-filename}. +@end defun + +@defun db->html-directory db dir index-filename + + +@defunx db->html-directory db dir +@var{db} must be a relational database. @var{dir} must be a non-empty +string naming an existing sub-directory of the current directory or +one to be created. The optional string @var{index-filename} names the filename of the +top page, which defaults to @file{index.html}. + +@code{db->html-directory} creates sub-directory @var{dir} if neccessary, and calls +@code{(db->html-files @var{db} @var{dir} @var{index-filename} @var{dir})}. The @samp{file:} URI of @var{index-filename} is +returned. +@end defun + +@defun db->netscape db dir index-filename + + +@defunx db->netscape db dir +@code{db->netscape} is just like @code{db->html-directory}, but calls +@code{browse-url-netscape} with the uri for the top page after the +pages are created. +@end defun diff --git a/module/slib/dbrowse.scm b/module/slib/dbrowse.scm new file mode 100644 index 000000000..082cef3e5 --- /dev/null +++ b/module/slib/dbrowse.scm @@ -0,0 +1,92 @@ +;;; "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 new file mode 100644 index 000000000..38ab4ab40 --- /dev/null +++ b/module/slib/dbutil.scm @@ -0,0 +1,313 @@ +;;; "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 new file mode 100644 index 000000000..4b50d9d53 --- /dev/null +++ b/module/slib/debug.scm @@ -0,0 +1,98 @@ +;;;; "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 new file mode 100644 index 000000000..4c6d8bd91 --- /dev/null +++ b/module/slib/defmacex.scm @@ -0,0 +1,100 @@ +;;;"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 new file mode 100644 index 000000000..4b53e5f06 --- /dev/null +++ b/module/slib/determ.scm @@ -0,0 +1,14 @@ +;"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 new file mode 100644 index 000000000..8d6480029 --- /dev/null +++ b/module/slib/dwindtst.scm @@ -0,0 +1,80 @@ +;;;; "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 new file mode 100644 index 000000000..937f93e0e --- /dev/null +++ b/module/slib/dynamic.scm @@ -0,0 +1,75 @@ +; "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 new file mode 100644 index 000000000..921242263 --- /dev/null +++ b/module/slib/dynwind.scm @@ -0,0 +1,74 @@ +; "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 new file mode 100644 index 000000000..022121c51 --- /dev/null +++ b/module/slib/elk.init @@ -0,0 +1,303 @@ +;;;"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 new file mode 100644 index 000000000..cc4b8168c --- /dev/null +++ b/module/slib/eval.scm @@ -0,0 +1,146 @@ +; "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 new file mode 100644 index 000000000..f10f0d589 --- /dev/null +++ b/module/slib/factor.scm @@ -0,0 +1,245 @@ +;;;; "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 new file mode 100644 index 000000000..0936c1cfc --- /dev/null +++ b/module/slib/fft.scm @@ -0,0 +1,70 @@ +;;;"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 new file mode 100644 index 000000000..59ba481cb --- /dev/null +++ b/module/slib/fluidlet.scm @@ -0,0 +1,40 @@ +; "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 new file mode 100644 index 000000000..3e2adb7cc --- /dev/null +++ b/module/slib/fmtdoc.txi @@ -0,0 +1,434 @@ + +@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 new file mode 100644 index 000000000..d9f1c86a4 --- /dev/null +++ b/module/slib/format.scm @@ -0,0 +1,1675 @@ +;;; "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 new file mode 100644 index 000000000..3f1913098 --- /dev/null +++ b/module/slib/formatst.scm @@ -0,0 +1,647 @@ +;; "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 new file mode 100644 index 000000000..6d4976fc5 --- /dev/null +++ b/module/slib/gambit.init @@ -0,0 +1,301 @@ +;;;"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 new file mode 100644 index 000000000..2e4bf6060 --- /dev/null +++ b/module/slib/genwrite.scm @@ -0,0 +1,266 @@ +;;"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 new file mode 100644 index 000000000..c2962dbbe --- /dev/null +++ b/module/slib/getopt.scm @@ -0,0 +1,80 @@ +;;; "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 new file mode 100644 index 000000000..d5bfe1f39 --- /dev/null +++ b/module/slib/getparam.scm @@ -0,0 +1,213 @@ +;;; "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 new file mode 100644 index 000000000..dc396cd54 --- /dev/null +++ b/module/slib/glob.scm @@ -0,0 +1,227 @@ +;;; "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/hash.scm b/module/slib/hash.scm new file mode 100644 index 000000000..ab021388e --- /dev/null +++ b/module/slib/hash.scm @@ -0,0 +1,153 @@ +; "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 new file mode 100644 index 000000000..317efe29a --- /dev/null +++ b/module/slib/hashtab.scm @@ -0,0 +1,79 @@ +; "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 new file mode 100644 index 000000000..66bf62ee0 --- /dev/null +++ b/module/slib/htmlform.scm @@ -0,0 +1,448 @@ +;;; "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 new file mode 100644 index 000000000..67e1aa530 --- /dev/null +++ b/module/slib/slib.spec @@ -0,0 +1,85 @@ +%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 new file mode 100644 index 000000000..5194f47e5 --- /dev/null +++ b/module/slib/slib.texi @@ -0,0 +1,11142 @@ +\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{