diff options
| author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:27 -0800 |
|---|---|---|
| committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:27 -0800 |
| commit | fa3f23105ddcf07c5900de47f19af43d1db1b597 (patch) | |
| tree | b2c6cce6b97698098f50cbc78c23fdc0f8d401ab | |
| parent | f24b9140d6f74804d5599ec225717d38ca443813 (diff) | |
| download | slib-fa3f23105ddcf07c5900de47f19af43d1db1b597.tar.gz slib-fa3f23105ddcf07c5900de47f19af43d1db1b597.zip | |
Import Upstream version 2c3upstream/2c3
| -rw-r--r-- | ANNOUNCE | 106 | ||||
| -rw-r--r-- | Bev2slib.scm | 118 | ||||
| -rw-r--r-- | ChangeLog | 272 | ||||
| -rw-r--r-- | FAQ | 46 | ||||
| -rw-r--r-- | Makefile | 52 | ||||
| -rw-r--r-- | README | 22 | ||||
| -rw-r--r-- | Template.scm | 13 | ||||
| -rw-r--r-- | batch.scm | 177 | ||||
| -rw-r--r-- | byte.scm | 1 | ||||
| -rw-r--r-- | chez.init | 2 | ||||
| -rw-r--r-- | cring.scm | 137 | ||||
| -rw-r--r-- | dbrowse.scm | 6 | ||||
| -rw-r--r-- | dbutil.scm | 83 | ||||
| -rw-r--r-- | elk.init | 3 | ||||
| -rw-r--r-- | eval.scm | 146 | ||||
| -rw-r--r-- | factor.scm | 33 | ||||
| -rw-r--r-- | fmtdoc.txi | 434 | ||||
| -rw-r--r-- | format.scm | 2 | ||||
| -rw-r--r-- | gambit.init | 4 | ||||
| -rw-r--r-- | getparam.scm | 152 | ||||
| -rw-r--r-- | glob.scm | 119 | ||||
| -rw-r--r-- | htmlform.scm | 663 | ||||
| -rw-r--r-- | logical.scm | 22 | ||||
| -rw-r--r-- | macscheme.init | 4 | ||||
| -rw-r--r-- | makcrc.scm | 2 | ||||
| -rw-r--r-- | mitscheme.init | 39 | ||||
| -rw-r--r-- | mklibcat.scm | 22 | ||||
| -rw-r--r-- | mwdenote.scm | 50 | ||||
| -rw-r--r-- | mwexpand.scm | 17 | ||||
| -rw-r--r-- | obj2str.scm | 3 | ||||
| -rw-r--r-- | paramlst.scm | 150 | ||||
| -rw-r--r-- | prec.scm | 38 | ||||
| -rw-r--r-- | primes.scm | 28 | ||||
| -rw-r--r-- | printf.scm | 433 | ||||
| -rw-r--r-- | qp.scm | 20 | ||||
| -rw-r--r-- | randinex.scm | 44 | ||||
| -rw-r--r-- | random.scm | 117 | ||||
| -rw-r--r-- | rdms.scm | 25 | ||||
| -rw-r--r-- | record.scm | 2 | ||||
| -rw-r--r-- | require.scm | 17 | ||||
| -rw-r--r-- | scheme2c.init | 3 | ||||
| -rw-r--r-- | scheme48.init | 5 | ||||
| -rw-r--r-- | schmooz.scm | 605 | ||||
| -rw-r--r-- | scsh.init | 7 | ||||
| -rw-r--r-- | slib.texi | 1265 | ||||
| -rw-r--r-- | sort.scm | 4 | ||||
| -rw-r--r-- | strcase.scm | 5 | ||||
| -rw-r--r-- | strsrch.scm | 22 | ||||
| -rw-r--r-- | t3.init | 3 | ||||
| -rw-r--r-- | timezone.scm | 34 | ||||
| -rw-r--r-- | trace.scm | 7 | ||||
| -rw-r--r-- | tzfile.scm | 2 | ||||
| -rw-r--r-- | vscm.init | 12 | ||||
| -rw-r--r-- | wttree.scm | 2 |
54 files changed, 4113 insertions, 1487 deletions
@@ -1,53 +1,49 @@ This message announces the availability of Scheme Library release -slib2c0. - -New in slib2c0: - - * 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. - * record.scm (display write): Records now display and write as - #<record-type-name>. - * 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. - * 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. - * 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. - * slib.texi (Database Utilities): Rewrote and expanded - command-line parser example. - -Thu Oct 23 23:14:33 1997 Eric Marsden <marsden@salines.cict.fr> - - * factor.scm (prime:product): added EXACT? test. - -Mon Oct 20 22:18:16 1997 Radey Shouman <shouman@zianet.com> - - * arraymap.scm (array-index-map!): Added. - (array-indexes): implemented with array-index-map! +slib2c3. + +New in slib2c3 are filename matching (a la Bash glob) and `Schmooz', a +lightweight markup language for interspersing Texinfo documentation +with Scheme source code. + + * slib.texi (Filenames): documented pattern strings. + * Makefile: Added $srcdir to TEXINPUTS for TeX. + * slib.texi (Schmooz): Added documentation. + * Makefile (info htmlform.txi): made smarter about when to run + schmooz. + * slib.texi (Format): documentation moved to fmtdoc.txi. + * glob.scm (filename:match?? filename:match-ci??): aliases added. + * primes.scm (primes:prngs): added to reduce likelyhood of + reentrant random calls. + * random.scm: rewritten using new seedable RNG. + * randinex.scm (random:uniform): Rewritten for new RNG. + * primes.scm (primes:dbsp?): Now requires 'root and uses + integer-sqrt for sqrt on platforms not supporting inexacts. + * record.scm (rtd-name): Fixed so record rtds print. + * cring.scm (*): Number distribution requires separate treatment. + * factor.scm (prime:factor): (factor 0) now returns '(0) rather + than infinite-looping. + * cring.scm (*): Added check for (* -1 (- <expr>)) case. + * 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. + * prec.scm (prec:nofix): Added . binds args, which are combined + with *syn-rules*. + + From: Radey Shouman <Radey_Shouman@splashtech.com> + + * glob.scm: Added. + * schmooz.scm (schmooz): Added @args markup command. + * schmooz.scm (schmooz): Now tries harder to determine whether a + definition is of a procedure or non-procedure variable. + Recognizes DEFMACRO, DEFINE-SYNTAX. + * 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. SLIB is a portable scheme library meant to provide compatibiliy and utility functions for all standard scheme implementations. @@ -62,14 +58,12 @@ package is supplied. SLIB Documentation is online at: http://www-swiss.ai.mit.edu/~jaffer/SLIB.html SLIB is a portable Scheme library: - ftp-swiss.ai.mit.edu:pub/scm/slib2c0.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/slib2c0.tar.gz - ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c0.tar.gz + ftp-swiss.ai.mit.edu:pub/scm/slib2c3.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/slib2c3.tar.gz SLIB-PSD is a portable debugger for Scheme (requires emacs editor): ftp-swiss.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz - ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz SCHELOG is an embedding of Prolog in Scheme+SLIB: http://www.cs.rice.edu/CS/PLT/packages/schelog/ @@ -87,13 +81,13 @@ relation to zip). The program to uncompress them is available from ftp ftp-swiss.ai.mit.edu (anonymous) bin cd pub/scm - get slib2c0.tar.gz + get slib2c3.tar.gz or ftp prep.ai.mit.edu (anonymous) cd pub/gnu/jacal bin - get slib2c0.tar.gz + get slib2c3.tar.gz - `slib2c0.tar.gz' is a compressed tar file of a Scheme Library. + `slib2c3.tar.gz' is a compressed tar file of a Scheme Library. Remember to use binary mode when transferring the *.tar.gz files. diff --git a/Bev2slib.scm b/Bev2slib.scm new file mode 100644 index 0000000..1198842 --- /dev/null +++ b/Bev2slib.scm @@ -0,0 +1,118 @@ +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of GUILE. +;; +;; The exception is that, if you link the GUILE library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the GUILE library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for GUILE, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;;;; "Bev2slib.scm" Build SLIB catalogs for Stephen Bevan's libraries. +;;; Author: Aubrey Jaffer. + +;;; 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* ")") + )))) @@ -1,3 +1,271 @@ +1998-09-11 Aubrey Jaffer <jaffer@colorage.com> + + * 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 <Radey_Shouman@splashtech.com> + + * schmooz.scm (schmooz): Added @args markup command. + +1998-09-09 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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 <jaffer@ai.mit.edu> + + * slib.texi (Schmooz): Added documentation. + + * Makefile (info htmlform.txi): made smarter about when to run + schmooz. + +1998-09-03 Radey Shouman <Radey_Shouman@splashtech.com> + + * 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 <jaffer@colorage.com> + + * slib.texi (Format): documentation moved to fmtdoc.txi. + + * glob.scm (filename:match?? filename:match-ci??): aliases added. + +1998-09-02 Radey Shouman <Radey_Shouman@splashtech.com> + + * glob.scm: Added. + +1998-09-01 Aubrey Jaffer <jaffer@colorage.com> + + * primes.scm (primes:prngs): added to reduce likelyhood of + reentrant random calls. + +1998-08-31 Aubrey Jaffer <jaffer@ai.mit.edu> + + * random.scm: rewritten using new seedable RNG. + + * randinex.scm (random:uniform): Rewritten for new RNG. + +1998-08-27 Aubrey Jaffer <jaffer@colorage.com> + + * primes.scm (primes:dbsp?): Now requires 'root and uses + integer-sqrt for sqrt on platforms not supporting inexacts. + +1998-08-25 <radey@colorage.com> + + * record.scm (rtd-name): Fixed so record rtds print. + +1998-08-16 Aubrey Jaffer <jaffer@ai.mit.edu> + + * cring.scm (*): Number distribution requires separate treatment. + +1998-08-11 Aubrey Jaffer <jaffer@ai.mit.edu> + + * factor.scm (prime:factor): (factor 0) now returns '(0) rather + than infinite-looping. + +1998-08-09 Aubrey Jaffer <jaffer@ai.mit.edu> + + * cring.scm (*): Added check for (* -1 (- <expr>)) case. + +1998-07-08 Aubrey Jaffer <jaffer@colorage.com> + + * 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 <jaffer@ai.mit.edu> + + * prec.scm (prec:nofix): Added . binds args, which are combined + with *syn-rules*. + +1998-06-12 Aubrey Jaffer <jaffer@colorage.com> + + * Makefile (dist): Added cvs flag command to dist target. + +1998-06-08 Aubrey Jaffer <jaffer@colorage.com> + + * 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 <jaffer@ai.mit.edu> + + * 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 <jaffer@scm.colorage.net> + +o * require.scm (*SLIB-VERSION*): Bumped from 2c1 to 2c2. + +1998-06-04 Aubrey Jaffer <jaffer@colorage.com> + + * 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 <jaffer@ai.mit.edu> + + * 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 <radey@scm.colorage.net> + + * Makefile: Added schmooz.scm to ffiles. + + * schmooz.scm: Texinfo document generator for Scheme programs. + +1998-06-02 Aubrey Jaffer <jaffer@colorage.com> + + * 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 <jaffer@ai.mit.edu> + + * 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 <jaffer@colorage.com> + + * htmlform.scm: Added http stuff. + +1998-05-24 Aubrey Jaffer <jaffer@ai.mit.edu> + + * cring.scm (make-rat rat-*): Removed support for rational numbers. + +1998-05-14 Radey Shouman <radey@colorage.com> + + * 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 <jaffer@scm.colorage.net> + + * require.scm (*SLIB-VERSION*): Bumped from 2c0 to 2c1. + +1998-04-14 Aubrey Jaffer <jaffer@colorage.com> + + * byte.scm (bytes-length): added synonym for string-length. + +1998-04-14 <radey@colorage.com> + + * printf.scm ((stdio:iprintf out format-string . args)): Added + %b descriptor -- outputs a binary number representation. + +1998-03-31 <radey@colorage.com> + + * 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 <radey@colorage.com> + + * require.scm (program-vicinity): Now gives more informative error + message when called from non-loading context. + +1998-02-10 William D Clinger <will@ccs.neu.edu> + + * mwexpand.scm (mw:case exp): added. + + * mwdenote.scm (mw:denote-of-case): added. + +1998-02-12 Aubrey Jaffer <jaffer@colorage.com> + + * 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 <jaffer@colorage.com> + + * slib.texi (Top): + (Extra-SLIB Packages): Converted to use of new texinfo feature + @url. + +1998-02-08 Aubrey Jaffer <jaffer@ai.mit.edu> + + * eval.scm (interaction-environment): fixed. + +1998-02-02 Aubrey Jaffer & Radey Shouman <jaffer@ai.mit.edu> + + * eval.scm (scheme-report-environment): implemented for version + arguments of 4 and 5. + +1998-02-01 Aubrey Jaffer <jaffer@ai.mit.edu> + + * eval.scm (eval): R5RS proposed EVAL implemented. + +Sun Dec 7 22:34:50 1997 Aubrey Jaffer <jaffer@ai.mit.edu> + + * 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 <jaffer@ai.mit.edu> + + * 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 <jaffer@martigny.ai.mit.edu> + + * paramlst.scm (parameter-list->getopt-usage): split out of + getopt->parameter-list. + +Wed Nov 26 23:49:53 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> + + * 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 <jaffer@martigny.ai.mit.edu> + + * 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 <jaffer@martigny.ai.mit.edu> + + * 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 <jaffer@martigny.ai.mit.edu> * cltime.scm (decode-universal-time encode-universal-time): @@ -42,7 +310,7 @@ Sun Nov 2 22:59:59 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> * 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 #f)): resets *catalog*. ((require 'new-catalog)): builds new catalog. * mklibcat.scm: Rewrote to output headers and combine @@ -923,7 +1191,7 @@ Sat Feb 5 00:19:38 1994 Aubrey Jaffer (jaffer@jacal) Fri Feb 4 00:54:14 1994 Aubrey Jaffer (jaffer@jacal) - From: pk@kaulushaikara.cs.tut.fi (Kellom{ki Pertti) + 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: @@ -1,5 +1,5 @@ -FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib2c0). -Written by Aubrey Jaffer (jaffer@ai.mit.edu). +FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib2c3). +Written by Aubrey Jaffer (http://www-swiss.ai.mit.edu/~jaffer). INTRODUCTION AND GENERAL INFORMATION @@ -14,16 +14,14 @@ Scheme is a programming language in the Lisp family. [] Which implementations has SLIB been ported to? -SLIB is currently supported by Chez, ELK 2.1, GAMBIT, MacScheme, -MITScheme, scheme->C, Scheme48, T3.1, SCM and VSCM +SLIB is supported by Chez, ELK 2.1, GAMBIT, MacScheme, MITScheme, +scheme->C, Scheme48, T3.1, SCM and VSCM [] How can I obtain SLIB? SLIB is available via ftp from: - ftp-swiss.ai.mit.edu:pub/scm/slib2c0.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/slib2c0.tar.gz - ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2c0.tar.gz - ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c0.tar.gz + ftp-swiss.ai.mit.edu:pub/scm/slib2c3.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/slib2c3.tar.gz SLIB is also included with SCM floppy disks. @@ -44,11 +42,11 @@ prep.ai.mit.edu:pub/gnu/texinfo-3.1.tar.gz [] How often is SLIB released? -SLIB was released twice in 1996. +Several times a year. [] What is the latest version? -The version as of this writing is slib2c0. The latest documentation +The version as of this writing is slib2c3. The latest documentation is available online at: http://www-swiss.ai.mit.edu/~jaffer/SLIB.html @@ -65,9 +63,8 @@ and slib/README. If you have Scheme and SLIB running, type Did you remember to set either the environment variable SCHEME_LIBRARY_PATH or the library-vicinity in your initialization -file to the correct location? Make sure if you set only the -environment variable SCHEME_LIBRARY_PATH that your implementation -supports getenv. +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 @@ -113,15 +110,15 @@ Scheme implementation. 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, the line is (require 'random). +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 currently 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 +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. @@ -152,7 +149,7 @@ 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 + ==> 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. @@ -181,9 +178,9 @@ powerful to accomplish tasks macros are often written to do. [] Why are there both R4RS macros and Common-Lisp style defmacros in SLIB? -Most current Scheme implementations predate the adoption of the R4RS -macro specification. All of the implementations except scheme48 -version 0.45 support defmacro natively. +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". @@ -194,9 +191,8 @@ The way to load the struct macro package is (REQUIRE 'YASOS). CELL?) The error I get is "variable define-predicate is undefined". -If your Scheme does not natively support R4RS macros (most -implementations), you will need to install a macro-capable -read-eval-print loop. This is done by: +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) @@ -1,5 +1,5 @@ # Makefile for Scheme Library -# Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997 Aubrey Jaffer. +# Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 Aubrey Jaffer. SHELL = /bin/sh intro: @@ -14,11 +14,11 @@ srcdir=$(HOME)/slib/ dvidir=../dvi/ dvi: $(dvidir)slib.dvi $(dvidir)slib.dvi: $(srcdir)slib.texi $(dvidir)slib.fn -# cd $(dvidir);texi2dvi $(srcdir)slib.texi - -(cd $(dvidir);texindex slib.??) - cd $(dvidir);tex $(srcdir)slib.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);tex $(srcdir)slib.texi + cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi xdvi: $(dvidir)slib.dvi xdvi -s 6 $(dvidir)slib.dvi htmldir=../public_html/ @@ -93,9 +93,15 @@ install48: slib48 > $(bindir)/slib48 chmod +x $(bindir)/slib48 +scheme = scm + +htmlform.txi: *.scm + $(scheme) -rschmooz -e'(schmooz "slib.texi")' + info: $(infodir)/slib.info -$(infodir)/slib.info: slib.texi +$(infodir)/slib.info: slib.texi htmlform.txi makeinfo slib.texi -o $(infodir)/slib.info + install-info $(infodir)/slib.info $(infodir)/dir -rm $(infodir)/slib.info*.gz infoz: $(infodir)/slib.info.gz @@ -104,15 +110,16 @@ $(infodir)/slib.info.gz: $(infodir)/slib.info #### Stuff for maintaining SLIB below #### -VERSION = 2c0 +VERSION = 2c3 ver = $(VERSION) 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 + strsrch.scm prec.scm schmooz.scm lfiles = sort.scm comlist.scm tree.scm logical.scm random.scm tsort.scm revfiles = sc4opt.scm sc4sc3.scm sc2.scm mularg.scm mulapply.scm \ - trnscrpt.scm withfile.scm dynwind.scm promise.scm values.scm + trnscrpt.scm withfile.scm dynwind.scm promise.scm values.scm \ + eval.scm afiles = ratize.scm randinex.scm modular.scm primes.scm factor.scm \ charplot.scm root.scm cring.scm determ.scm selfset.scm \ psxtime.scm cltime.scm timezone.scm tzfile.scm @@ -127,10 +134,12 @@ efiles = record.scm dynamic.scm queue.scm process.scm \ wttree.scm wttest.scm array.scm arraymap.scm \ sierpinski.scm soundex.scm byte.scm rfiles = rdms.scm alistab.scm dbutil.scm paramlst.scm report.scm \ - batch.scm makcrc.scm dbrowse.scm comparse.scm getopt.scm + batch.scm makcrc.scm dbrowse.scm comparse.scm getopt.scm \ + htmlform.scm getparam.scm glob.scm gfiles = tek40.scm tek41.scm -docfiles = ANNOUNCE README FAQ ChangeLog slib.texi -mfiles = Makefile require.scm Template.scm syncase.sh mklibcat.scm +docfiles = ANNOUNCE README FAQ ChangeLog slib.texi fmtdoc.txi +mfiles = Makefile require.scm Template.scm syncase.sh mklibcat.scm \ + Bev2slib.scm ifiles = chez.init elk.init macscheme.init \ mitscheme.init scheme2c.init scheme48.init gambit.init t3.init \ vscm.init mitcomp.pat scm.init scsh.init @@ -160,9 +169,17 @@ $(dest)slib.info.tar.gz: infotemp/slib $(makedev) TEMP=infotemp/ DEST=$(dest) PROD=slib ver=.info tar.gz rm -rf infotemp +release: dist + rsync -v $(htmldir)SLIB.html martigny.ai.mit.edu:public_html/ + rsync -v $(dest)README $(dest)slib$(VERSION).tar.gz martigny.ai.mit.edu:dist/ + upload $(dest)README $(dest)slib$(VERSION).tar.gz prep.ai.mit.edu:gnu/jacal/ +upzip: $(HOME)/pub/slib.zip + rsync -v $(HOME)/pub/slib.zip martigny.ai.mit.edu:pub/ + dist: $(dest)slib$(VERSION).tar.gz $(dest)slib$(VERSION).tar.gz: temp/slib $(makedev) DEST=$(dest) PROD=slib ver=$(VERSION) tar.gz + cvs tag -F slib$(VERSION) shar: slib.shar slib.shar: temp/slib $(makedev) PROD=slib shar @@ -186,7 +203,7 @@ pubdiffs: temp/slib distdiffs: temp/slib $(makedev) DEST=$(dest) PROD=slib ver=$(ver) distdiffs announcediffs: temp/slib - $(makedev) DEST=$(dest) PROD=slib ver=2c0 announcediffs + $(makedev) DEST=$(dest) PROD=slib ver=2c3 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 @@ -214,14 +231,15 @@ new: mv -f change ChangeLog $(CHPAT) slib$(VERSION) slib$(ver) ANNOUNCE FAQ ../scm/ANNOUNCE \ ../jacal/ANNOUNCE ../wb/README ../wb/ANNOUNCE \ - ../public_html/README.html ../dist/README \ - ../public_html/SLIB.html ../public_html/JACAL.html \ - ../public_html/SCM.html ../public_html/Hobbit.html \ + $(htmldir)README.html ../dist/README \ + $(htmldir)SLIB.html $(htmldir)JACAL.html \ + $(htmldir)SCM.html $(htmldir)Hobbit.html \ + $(htmldir)SIMSYNCH.html \ ../scm/README ../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 \ - ../public_html/SLIB.html + $(htmldir)SLIB.html tagfiles = slib.texi $(mfiles) $(sfiles) $(bfiles) $(tfiles) # README and $(ifiles) cause semgentation faults in ETAGS for Emacs version 19. @@ -1,9 +1,10 @@ -This directory contains the distribution of Scheme Library slib2c0. -Slib conforms to Revised^4 Report on the Algorithmic Language Scheme +This directory contains the distribution of Scheme Library slib2c3. +Slib conforms to Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. Slib supports Unix and similar systems, VMS, and MS-DOS. -The maintainer can be reached at jaffer@ai.mit.edu. +The maintainer can be reached at jaffer @ life.ai.mit.edu. + http://www-swiss.ai.mit.edu/~jaffer/SLIB.html MANIFEST @@ -32,6 +33,7 @@ The maintainer can be reached at jaffer@ai.mit.edu. `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. @@ -80,9 +82,15 @@ The maintainer can be reached at jaffer@ai.mit.edu. `alistab.scm' has association list base tables. `dbutil.scm' has utilities for creating and manipulating relational databases. + `htmlform' generates HTML2.0 forms and service CGI requests from RDB + command tables. `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. @@ -134,6 +142,7 @@ The maintainer can be reached at jaffer@ai.mit.edu. `trnscrpt.scm' has transcript-on and transcript-off from Revised^4 spec. `withfile.scm' has with-input-from-file and with-output-to-file from R4RS. `dynwind.scm' has proposed dynamic-wind from R5RS. + `eval.scm' has proposed eval with environments from R5RS. `dwindtst.scm' has routines for characterizing dynamic-wind. `dynamic.scm' has proposed DYNAMIC data type. `fluidlet.scm' has fluid-let syntax. @@ -185,8 +194,11 @@ the name `slib48' which will invoke the saved image. 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' or `Revised^4 Report on the -Algorithmic Language Scheme' to support SLIB. +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 diff --git a/Template.scm b/Template.scm index 55011b2..e3d2687 100644 --- a/Template.scm +++ b/Template.scm @@ -103,7 +103,7 @@ ; char-ready? ; macro ;has R4RS high level macros ; defmacro ;has Common Lisp DEFMACRO -; eval ;SLIB:EVAL is single argument eval +; eval ;R5RS two-argument eval ; record ;has user defined data structures ; values ;proposed multiple values ; dynamic-wind ;proposed dynamic-wind @@ -168,9 +168,8 @@ ;;; 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) +;;; 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) @@ -210,9 +209,6 @@ (define (defmacro:expand* x) (require 'defmacroexpand) (apply defmacro:expand* x '())) -(define (defmacro:load <pathname>) - (slib:eval-load <pathname> defmacro:eval)) - (define (slib:eval-load <pathname> evl) (if (not (file-exists? <pathname>)) (set! <pathname> (string-append <pathname> (scheme-file-suffix)))) @@ -225,6 +221,9 @@ (evl o)) (set! *load-pathname* old-load-pathname))))) +(define (defmacro:load <pathname>) + (slib:eval-load <pathname> defmacro:eval)) + (define slib:warn (lambda args (let ((port (current-error-port))) @@ -34,7 +34,11 @@ ;;(trace system system:success? exit quit slib:exit) (define (batch:port parms) - (car (parameter-list-ref parms 'batch-port))) + (let ((bp (parameter-list-ref parms 'batch-port))) + (cond ((or (not (pair? bp)) (not (output-port? (car bp)))) + ;;(slib:error '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))) @@ -49,13 +53,11 @@ ((system) 1023) ((*unknown*) -1)))))) +(define (write-batch-line str line-limit port) + (cond ((and line-limit (>= (string-length str) line-limit)) #f) + (else (write-line str port) #t))) (define (batch-line parms str) - (let ((bp (parameter-list-ref parms 'batch-port)) - (ln (batch:line-length-limit parms))) - (cond ((not bp) (slib:error 'batch-line "missing batch-port parameter" - parms)) - ((>= (string-length str) ln) #f) - (else (write-line str (car bp)) #t)))) + (write-batch-line str (batch:line-length-limit parms) (batch:port parms))) ;;; add a Scheme batch-dialect? @@ -70,56 +72,50 @@ (else (loop (nthcdr (+ 1 hlen) fodder)) (loop (butlast fodder hlen))))))) -(define (batch:system parms . strings) - (cond ((not (provided? 'system)) - (slib:error 'batch:system 'system "procedure not supported.")) - ((apply batch:try-system parms strings)) - (else (slib:error 'batch:system 'failed strings)))) - (define (batch:try-system parms . strings) - (define port (batch:port parms)) (set! strings (batch:flatten strings)) (case (batch:dialect parms) ((unix) (batch-line parms (apply string-join " " strings))) ((dos) (batch-line parms (apply string-join " " strings))) ((vms) (batch-line parms (apply string-join " " "$" strings))) - ((system) (cond ((provided? 'system) - (write `(system ,(apply string-join " " strings)) port) - (newline port) - (system:success? (system (apply string-join " " strings)))) - (else #f))) - ((*unknown*) (write `(system ,(apply string-join " " strings)) port) - (newline port) - #f))) + ((system) + (let ((port (batch:port parms)) + (str (apply string-join " " strings))) + (write `(system ,str) port) (newline port) + (and (provided? 'system) (system:success? (system str))))) + ((*unknown*) + (let ((port (batch:port parms)) + (str (apply string-join " " strings))) + (write `(system ,str) port) (newline port)) + #t) + (else #f))) + +(define (batch:system parms . strings) + (cond ((apply batch:try-system parms strings)) + (else (slib:error 'batch:system 'failed strings)))) (define (batch:run-script parms name . strings) (case (batch:dialect parms strings) ((vms) (batch:system parms (string-append "@" name) strings)) (else (batch:system 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)) + ((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)) - (case (batch:dialect parms) - ((unix) (every (lambda (line) - (batch-line parms (string-append "# " line))) - lines)) - ((dos) (every (lambda (line) - (batch-line parms - (string-append - "rem" (if (equal? " " line) ".") line))) - lines)) - ((vms) (every (lambda (line) - (batch-line parms (string-append "$! " line))) - lines)) - ((system) (every (lambda (line) - (batch-line parms (string-append "; " line))) - lines)) - ((*unknown*) (for-each (lambda (line) - (batch-line parms (string-append ";;; " line)) - (newline port)) - lines) - #f))) + (every (lambda (line) + (batch:write-comment-line dialect line port)) + lines)) (define (batch:lines->file parms file . lines) (define port (batch:port parms)) @@ -195,61 +191,57 @@ (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) - (case (batch:dialect parms) + (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))))) + (else (lambda (proc) (proc (current-output-port))))) (lambda (port) (write-line "#!/bin/sh" port) - (cond - ((and (string? name) (provided? 'bignum)) - (require 'posix-time) - (write-line - (string-append - "# \"" name "\" build script created " - (ctime (current-time))) - 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))))) + (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (cond - ((and (string? name) (provided? 'bignum)) - (require 'posix-time) - (write-line - (string-append - "rem " name - " build script created " - (ctime (current-time))) - 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))))) + (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (cond - ((and (string? name) (provided? 'bignum)) - (require 'posix-time) - ;;(write-line - ;; "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port) - (write-line - (string-append - "$! " name - " build script created " - (ctime (current-time))) - port))) + (batch:write-header-comment dialect name port) + ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port) (proc port)))) ((system) ((cond ((and (string? name) (provided? 'system)) @@ -259,16 +251,9 @@ (system (string-append "chmod +x " name)) ans))) ((output-port? name) (lambda (proc) (proc name))) - (else (lambda (proc) (proc (current-output-port))))) + (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (cond - ((and (string? name) (provided? 'bignum)) - (require 'posix-time) - (write-line - (string-append - ";;; \"" name - "\" build script created " (ctime (current-time))) - port))) + (batch:write-header-comment dialect name port) (proc port)))) ((*unknown*) ((cond ((and (string? name) (provided? 'system)) @@ -278,18 +263,10 @@ (system (string-append "chmod +x " name)) ans))) ((output-port? name) (lambda (proc) (proc name))) - (else (lambda (proc) (proc (current-output-port))))) + (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (cond - ((and (string? name) (provided? 'bignum)) - (require 'posix-time) - (write-line - (string-append - ";;; \"" name - "\" build script created " (ctime (current-time))) - port))) - (proc port))) - #f))) + (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 @@ -328,17 +305,6 @@ ((string? chars) (set! chars (string->list chars)))) (if (string? str) (tut str) (map tut str))) -(define (replace-suffix str old new) - (define (cs str) - (let* ((len (string-length str)) - (re (- len (string-length old)))) - (cond ((string-ci=? old (substring str re len)) - (string-append (substring str 0 re) new)) - (else - (slib:error 'replace-suffix "suffix doens't match:" - old str))))) - (if (string? str) (cs str) (map cs 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))) @@ -439,4 +405,3 @@ ((database 'add-domain) '(operating-system operating-system #f symbol #f)) ) - @@ -5,6 +5,7 @@ (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))) @@ -154,7 +154,7 @@ compiled ; Chez Scheme can also load compiled Scheme files, with the ; command (slib:load-compiled "filename") -- see below. - char-ready? delay dynamic-wind eval fluid-let format + char-ready? delay dynamic-wind fluid-let format full-continuation getenv ieee-p1178 macro multiarg/and- multiarg-apply pretty-print random random-inexact rationalize rev3-procedures rev3-report rev4-optional-procedures rev4-report @@ -81,40 +81,6 @@ (define number0? zero?) (define (zero? x) (and (number? x) (number0? x))) -(define (make-rat n d) - (let* ((g (if (negative? d) (number- (gcd n d)) (gcd n d))) - (n/g (quotient n g)) - (d/g (quotient d g))) - (case d/g - ((1) n/g) - (else - (case n/g - ((0) 0) - ((1) (list '/ d/g)) - (else (list '/ n/g d/g))))))) - -(define (rat-number? r) - (and (list? r) - (<= 2 (length r) 3) - (eq? '/ (car r)) - (every number? (cdr r)))) - -(define (rat-numerator r) - (cond ((number? r) r) - ((rat-number? r) - (case (length r) - ((2) 1) - ((3) (cadr r)))) - (else (slib:error 'rat-numerator "of non-rat" r)))) - -(define (rat-denominator r) - (cond ((number? r) 1) - ((rat-number? r) - (case (length r) - ((2) (cadr r)) - ((3) (caddr r)))) - (else (slib:error 'rat-denominator "of non-rat" r)))) - ;; 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 @@ -124,55 +90,41 @@ ;;; 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) (denoms 1) (arg.exps '())) + (let loop ((args args) (pow 1) (nums 1) (arg.exps '())) ;;(print (list 'loop args pow nums denoms arg.exps) '==>) - (cond ((null? args) (cons (make-rat 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 nums (number* num^pow denoms) arg.exps) - (loop (cdr args) pow (number* num^pow nums) denoms arg.exps)))) - ((rat-number? (car args)) - (let ((num^pow (number^ (rat-numerator (car args)) (abs pow))) - (den^pow (number^ (rat-denominator (car args)) (abs pow)))) - (if (negative? pow) - (loop (cdr args) pow - (number* den^pow nums) - (number* num^pow denoms) arg.exps) - (loop (cdr args) pow - (number* num^pow nums) - (number* den^pow denoms) arg.exps)))) + (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 denoms - arg.exps)) + 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) denoms arg.exps)) + (set! arg.exps (loop (cdar args) pow (number- nums) arg.exps)) (loop (cdr args) pow - (rat-numerator (car arg.exps)) - (rat-denominator (car arg.exps)) + (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 denoms arg.exps)) + (set! arg.exps (loop (cdar args) (number- pow) nums arg.exps)) (loop (cdr args) pow - (rat-numerator (car arg.exps)) - (rat-denominator (car arg.exps)) + (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 denoms 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 - (rat-numerator (car arg.exps)) - (rat-denominator (car arg.exps)) + (car arg.exps) (cdr arg.exps))) ;; Pull out numeric exponents as powers ((and (is-term-op? (car args) '^) @@ -180,17 +132,15 @@ (number? (caddar args))) (set! arg.exps (loop (list (cadar args)) (number* pow (caddar args)) - nums denoms + nums arg.exps)) - (loop (cdr args) pow - (rat-numerator (car arg.exps)) - (rat-denominator (car arg.exps)) (cdr 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 denoms arg.exps))) + (loop (cdr args) pow nums arg.exps))) ;; Add new term to arg.exps - (else (loop (cdr args) pow nums denoms + (else (loop (cdr args) pow nums (cons (cons (car args) pow) arg.exps)))))) ;;; Converts + argument list to CR internal form @@ -282,6 +232,7 @@ (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))) @@ -295,18 +246,25 @@ '* 1 '/ '^ (apply (lambda (numeric red.cofs res.cofs) + (set! num numeric) (append - (cond ((number? numeric) - (set! num numeric) - (list (cons (abs numeric) 1))) - (else - (set! num (rat-numerator numeric)) - (list (cons (abs num) 1) - (cons (rat-denominator numeric) -1)))) + ;;(list (cons (abs numeric) 1)) red.cofs res.cofs)) (cr1 '* number* '^ '/ (car in) (cdr in)))))) - (if (negative? num) (list '- ans) ans)))))))) + (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) @@ -360,23 +318,21 @@ (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) - (if (null? arg.pows) - (list numeric red.pows res.pows) - (loop.arg.pow.s (caar arg.pows) (cdar arg.pows) (cdr arg.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)))))) + (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)) @@ -452,7 +408,8 @@ (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) (number? arg)) (arg-loop arg.pows)) + (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))) diff --git a/dbrowse.scm b/dbrowse.scm index aaa4635..8008c04 100644 --- a/dbrowse.scm +++ b/dbrowse.scm @@ -1,5 +1,5 @@ ;;; "dbrowse.scm" relational-database-browser -; Copyright 1996 Aubrey Jaffer +; Copyright 1996, 1997 Aubrey Jaffer ; ;Permission to copy this software, to redistribute it, and to use it ;for any purpose is granted, subject to the following restrictions and @@ -23,7 +23,7 @@ (define browse:db #f) (define (browse . args) - (define table-name '*catalog-data*) + (define table-name #f) (cond ((null? args)) ((procedure? (car args)) (set! browse:db (car args)) @@ -37,7 +37,7 @@ (catalog (and open-table (open-table '*catalog-data* #f)))) (cond ((not catalog) (slib:error 'browse "could not open catalog")) - ((eq? table-name '*catalog-data*) + ((not table-name) (browse:display-dir '*catalog-data* catalog)) (else (let ((table (open-table table-name #f))) @@ -56,6 +56,19 @@ 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) @@ -71,9 +84,10 @@ (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 #f) - (parameter-name-translation *catalog-data* #f symbol #f) - (parameter-arity parameter-arity #f symbol #f))) + '((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* @@ -94,6 +108,36 @@ ((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) @@ -110,26 +154,29 @@ (lambda (domain) (let ((fkname (ro:for-tab domain)) (dir (slib:eval (ro:get-dir domain)))) - (cond (fkname (let* ((fktab ((rdb 'open-table) fkname #f)) - (p? (fktab 'get 1))) - (cond (dir (lambda (e) (and (dir e) (p? e)))) - (else p?)))) - (else dir)))))) + (if fkname (let* ((fktab ((rdb 'open-table) fkname #f)) + (p? (fktab 'get 1))) + (if dir (lambda (e) (and (dir e) (p? e))) p?)) + dir))))) "return procedure to check given domain name") (add-domain - no-parameters - no-parameter-names + add-domain-params + add-domain-pnames (lambda (rdb) - (((rdb 'open-table) '*domains-data* #t) 'row:insert)) - "given the row describing it, add a domain") + (((rdb 'open-table) '*domains-data* #t) 'row:update)) + "add a new domain") (delete-domain - no-parameters - no-parameter-names + del-domain-params + del-domain-pnames (lambda (rdb) (((rdb 'open-table) '*domains-data* #t) 'row:remove)) - "given its name, delete a domain")))) + "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-command-server rdb command-table) @@ -139,8 +186,8 @@ (comgetrow (comtab 'row:retrieve))) (lambda (comname command-callback) (let* ((command:row (comgetrow comname)) - (parameter-table ((rdb 'open-table) - (row-ref command:row 'parameters) #f)) + (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)) @@ -174,7 +221,7 @@ #f))) ((((rdb 'open-table) '*domains-data* #t) 'row:insert) (list dname dname #f - (dom:typ ((ftab 'get 'domain-name) 1)) #f)))))) + (dom:typ ((ftab 'get 'domain-name) 1)) 1)))))) (define (define-table name prikeys slots data) (cond ((table-exists? name) @@ -176,8 +176,7 @@ ;;; Return argument (define (identity x) x) -;;; If your implementation provides eval SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) (define *macros* '()) diff --git a/eval.scm b/eval.scm new file mode 100644 index 0000000..cc4b816 --- /dev/null +++ b/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-ci>=? char-ci>? char-downcase + char-lower-case? char-numeric? char-upcase char-upper-case? + char-whitespace? char<=? char<? 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-ci>=? string-ci>? string-copy + string-fill! string-length string-ref string-set! string<=? + string<? 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) @@ -130,21 +130,24 @@ (prime:f u (+ v b) (+ b b) (quotient (- n u) 2)))))) (define (prime:factor m) - (if - (negative? m) (cons -1 (prime:factor (- m))) - (let* ((s (gcd m prime:product)) - (r (quotient m s))) - (if (even? s) - (append - (if (= 1 r) '() (prime:factor r)) - (cons 2 (let ((s/2 (quotient s 2))) - (if (= s/2 1) '() - (or (prime:f 1 1 2 (quotient (- s/2 1) 2)) - (list s/2)))))) - (if (= 1 s) (or (prime:f 1 1 2 (quotient (- m 1) 2)) (list m)) - (append (if (= 1 r) '() - (or (prime:f 1 1 2 (quotient (- r 1) 2)) (list r))) - (or (prime:f 1 1 2 (quotient (- s 1) 2)) (list s)))))))) + (case m + ((-1 0 1) (list m)) + (else + (if (negative? m) (cons -1 (prime:factor (- m))) + (let* ((s (gcd m prime:product)) + (r (quotient m s))) + (if (even? s) + (append + (if (= 1 r) '() (prime:factor r)) + (cons 2 (let ((s/2 (quotient s 2))) + (if (= s/2 1) '() + (or (prime:f 1 1 2 (quotient (- s/2 1) 2)) + (list s/2)))))) + (if (= 1 s) (or (prime:f 1 1 2 (quotient (- m 1) 2)) (list m)) + (append + (if (= 1 r) '() + (or (prime:f 1 1 2 (quotient (- r 1) 2)) (list r))) + (or (prime:f 1 1 2 (quotient (- s 1) 2)) (list s)))))))))) (define jacobi-symbol prime:jacobi-symbol) (define prime? prime:prime?) diff --git a/fmtdoc.txi b/fmtdoc.txi new file mode 100644 index 0000000..40064f0 --- /dev/null +++ b/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{~}<newline> +Continuation Line. +@table @asis +@item @code{~:}<newline> +newline is ignored, white space left. +@item @code{~@@}<newline> +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 @@ -429,7 +429,7 @@ (anychar-dispatch)) ((#\|) ; Page seperator (if (one-positive-integer? params) - (format:out-str (car params) slib:form-feed) + (format:out-fill (car params) slib:form-feed) (format:out-char slib:form-feed)) (set! format:output-col 0) (anychar-dispatch)) diff --git a/gambit.init b/gambit.init index 752d9d0..255476f 100644 --- a/gambit.init +++ b/gambit.init @@ -107,7 +107,6 @@ 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 @@ -175,8 +174,7 @@ ;;; Return argument (define (identity x) x) -;;; If your implementation provides eval SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) ; Define program-arguments as argv diff --git a/getparam.scm b/getparam.scm new file mode 100644 index 0000000..ad4baba --- /dev/null +++ b/getparam.scm @@ -0,0 +1,152 @@ +;;; "getparam.scm" convert getopt to passing parameters by name. +; Copyright 1995, 1996, 1997 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;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) + +(define (getopt->parameter-list argc argv optnames arities types aliases) + (define (can-take-arg? opt) + (not (eq? (list-ref arities (position opt optnames)) + 'boolean))) + (define (coerce-val val curopt) + (define ntyp (list-ref types (position curopt optnames))) + (case ntyp + ((expression) val) + (else (coerce val ntyp)))) + (let ((starting-optind *optind*) + (optlist '()) + (long-opt-list '()) + (optstring #f) + (parameter-list (make-parameter-list optnames)) + (curopt '*unclaimed-argument*)) + (set! aliases (map (lambda (alias) + (define str (string-copy (car alias))) + (do ((i (+ -1 (string-length str)) (+ -1 i))) + ((negative? i) (cons str (cdr alias))) + (cond ((char=? #\ (string-ref str i)) + (string-set! str i #\-))))) + aliases)) + (for-each + (lambda (alias) + (define opt (car alias)) + (cond ((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 + ((#\: #\?) + (parameter-list->getopt-usage (list-ref argv (+ -1 starting-optind)) + optnames arities types aliases) + (slib:error 'getopt->parameter-list + (case opt + ((#\:) "argument missing after") + ((#\?) "unrecognized option")) + (string #\- getopt:opt))) + ((#f) + (cond ((and (< *optind* argc) + (string=? "-" (list-ref argv *optind*))) + (set! *optind* (+ 1 *optind*))) + ((< *optind* argc) + (cond ((and (member curopt optnames) + (adjoin-parameters! + parameter-list + (list curopt + (coerce-val (list-ref argv *optind*) + curopt)))) + (set! *optind* (+ 1 *optind*)) + (loop)) + (else (slib:error 'getopt->parameter-list curopt + (list-ref argv *optind*) + "not supported")))))) + (else + (cond ((char? opt) (set! opt (string opt)))) + (let ((topt (assoc opt aliases))) + (cond (topt (set! topt (cadr topt))) + (else (slib:error "Option not recognized -" opt))) + (cond + ((not (can-take-arg? topt)) + (adjoin-parameters! parameter-list (list topt #t))) + (*optarg* + (set! curopt topt) + (adjoin-parameters! parameter-list + (list topt (coerce-val *optarg* curopt)))) + (else + (set! curopt topt) +;;; (slib:warn 'getopt->parameter-list +;;; "= missing for option--" opt) + ))) + (loop))))) + parameter-list)) + +(define (parameter-list->getopt-usage comname optnames arities types aliases) + (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) + (newline cep) (newline cep) + (for-each + (lambda (optname arity aliat) + (let loop ((initials (remove-if-not strlen=1? (cdr aliat))) + (longname (remove-if strlen=1? (cdr aliat)))) + (cond ((and (null? initials) (null? longname))) + (else (fprintf cep + (case arity + ((boolean) " %3s %s") + (else " %3s %s<%s> %s")) + (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 ""))) + (newline cep) + (loop (if (null? initials) '() (cdr initials)) + (if (null? longname) '() (cdr longname))))))) + optnames arities aliast))) + +(define (getopt->arglist argc argv optnames positions + arities types defaulters checks aliases) + (let* ((params (getopt->parameter-list + argc argv optnames arities types aliases)) + (fparams (fill-empty-parameters defaulters params))) + (and (list? params) (check-parameters checks fparams)) + (and (list? params) (parameter-list->arglist positions arities fparams)))) diff --git a/glob.scm b/glob.scm new file mode 100644 index 0000000..5f692b7 --- /dev/null +++ b/glob.scm @@ -0,0 +1,119 @@ +;;; 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: /usr/local/cvsroot/slib/glob.scm,v 1.2 1998/09/03 15:34:59 jaffer Exp $ +;;$Name: $ + +(define (glob:match?? pat) + (glob:make-matcher pat char-ci=? char=?)) +(define (glob:match-ci?? pat) + (glob:make-matcher pat char-ci<=? char<=?)) + +(define (glob:make-matcher pat ch=? ch<=?) + (define (match-end str k) + (= k (string-length str))) + (define (match-char ch nxt) + (lambda (str k) + (and (< k (string-length str)) + (ch=? ch (string-ref str k)) + (nxt str (+ k 1))))) + (define (match-? nxt) + (lambda (str k) + (and (< k (string-length str)) + (nxt str (+ k 1))))) + (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 chrs nxt) + (if (and (positive? (string-length chrs)) + (memv (string-ref chrs 0) '(#\^ #\!))) + (let ((pred (match-set1 (substring chrs 1 (string-length chrs))))) + (lambda (str k) + (and (< k (string-length str)) + (not (pred (string-ref str k))) + (nxt str (+ k 1))))) + (let ((pred (match-set1 chrs))) + (lambda (str k) + (and (< k (string-length str)) + (pred (string-ref str k)) + (nxt str (+ k 1))))))) + (define (match-* nxt) + (lambda (str k) + (let loop ((kk (string-length str))) + (and (>= kk k) + (or (nxt str kk) + (loop (- kk 1))))))) + + (let ((matcher + (let recur ((i 0)) + (if (= i (string-length pat)) + match-end + (let ((pch (string-ref pat i))) + (case pch + ((#\?) + (let ((nxt (recur (+ i 1)))) + (match-? nxt))) + ((#\*) + (let ((nxt (recur (+ i 1)))) + (match-* nxt))) + ((#\[) + (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))))))) + (let ((nxt (recur (+ j 1)))) + (match-set (substring pat (+ i 1) j) nxt)))) + (else (let ((nxt (recur (+ i 1)))) + (match-char pch nxt))))))))) + (lambda (str) (matcher str 0)))) + +(define filename:match?? glob:match??) +(define filename:match-ci?? glob:match-ci??) + +(define (replace-suffix str old new) + (define (cs str) + (let* ((len (string-length str)) + (re (- len (string-length old)))) + (cond ((string-ci=? old (substring str re len)) + (string-append (substring str 0 re) new)) + (else + (slib:error 'replace-suffix "suffix doesn't match:" + old str))))) + (if (string? str) (cs str) (map cs str))) diff --git a/htmlform.scm b/htmlform.scm new file mode 100644 index 0000000..f8656e2 --- /dev/null +++ b/htmlform.scm @@ -0,0 +1,663 @@ +;;; "htmlform.scm" Generate HTML 2.0 forms and -*-scheme-*- +;;; service CGI requests from RDB command table. +; Copyright 1997, 1998 Aubrey Jaffer +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;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 'scanf) +(require 'printf) +(require 'line-i/o) +(require 'parameters) +(require 'fluid-let) +(require 'dynamic-wind) +(require 'string-case) +(require 'string-port) +(require 'string-search) +(require 'database-utilities) +(require 'common-list-functions) + +;;;;@code{(require 'html-form)} + +;;@body Procedure names starting with @samp{html:} send their output +;;to the port @0. @0 is initially the current output port. +(define *html:output-port* (current-output-port)) + +(define (html:printf . args) (apply fprintf *html:output-port* args)) + +;;@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))) + (string-subst 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' + (if (symbol? txt) (set! txt (symbol->string txt))) + (string-subst txt + "&" "&" + "<" "<" + ">" ">")) + +;;@body Writes (using @code{html:printf}) the strings @1 as HTML +;;comments. +(define (html:comment . lines) + (html:printf "<!") + (for-each (lambda (line) + (if (substring? "--" line) + (slib:error 'html:comment "line contains --" line) + (html:printf "--%s--\\n" line))) + lines) + (html:printf ">\\n")) + +(define (html:dt-strong-doc name doc) + (if (and (string? doc) (not (equal? "" doc))) + (html:printf "<DT><STRONG>%s</STRONG> (%s)\\n" + (html:plain name) (html:plain doc)) + (html:printf "<DT><STRONG>%s</STRONG>\\n" (html:plain name)))) + +(define (html:checkbox name doc pname) + (html:printf "<DT><INPUT TYPE=CHECKBOX NAME=%#a VALUE=T>\\n" + (html:atval pname)) + (if (and (string? doc) (not (equal? "" doc))) + (html:printf "<DD><STRONG>%s</STRONG> (%s)\\n" + (html:plain name) (html:plain doc)) + (html:printf "<DD><STRONG>%s</STRONG>\\n" (html:plain name)))) + +(define (html:text name doc pname default) + (cond (default + (html:dt-strong-doc name doc) + (html:printf "<DD><INPUT NAME=%#a SIZE=%d VALUE=%#a>\\n" + (html:atval pname) + (max 20 (string-length + (if (symbol? default) + (symbol->string default) default))) + (html:atval default))) + (else + (html:dt-strong-doc name doc) + (html:printf "<DD><INPUT NAME=%#a>\\n" (html:atval pname))))) + +(define (html:text-area name doc pname default-list) + (html:dt-strong-doc name doc) + (html:printf "<DD><TEXTAREA NAME=%#a ROWS=%d COLS=%d>\\n" + (html:atval pname) (max 2 (length default-list)) + (apply max 32 (map (lambda (d) (string-length + (if (symbol? d) + (symbol->string d) + d))) + default-list))) + (for-each (lambda (line) (html:printf "%s\\n" (html:plain line))) default-list) + (html:printf "</TEXTAREA>\\n")) + +(define (html:s<? s1 s2) + (if (and (number? s1) (number? s2)) + (< s1 s2) + (string<? (if (symbol? s1) (symbol->string s1) s1) + (if (symbol? s2) (symbol->string s2) s2)))) + +(define (html:select name doc pname arity default-list value-list) + (set! value-list (sort! value-list html:s<?)) + (html:dt-strong-doc name doc) + (html:printf "<DD><SELECT NAME=%#a SIZE=%d%s>\\n" + (html:atval pname) + (case arity + ((single optional) 1) + ((nary nary1) 5)) + (case arity + ((nary nary1) " MULTIPLE") + (else ""))) + (for-each (lambda (value) + (html:printf "<OPTION VALUE=%#a%s>%s\\n" + (html:atval value) + (if (member value default-list) + " SELECTED" "") + (html:plain value))) + (case arity + ((optional nary) (cons (string->symbol "") value-list)) + (else value-list))) + (html:printf "</SELECT>\\n")) + +(define (html:buttons name doc pname arity default-list value-list) + (set! value-list (sort! value-list html:s<?)) + (html:dt-strong-doc name doc) + (html:printf "<DD><MENU>") + (case arity + ((single optional) + (for-each (lambda (value) + (html:printf + "<LI><INPUT TYPE=RADIO NAME=%#a VALUE=%#a%s> %s\\n" + (html:atval pname) (html:atval value) + (if (member value default-list) " CHECKED" "") + (html:plain value))) + value-list)) + ((nary nary1) + (for-each (lambda (value) + (html:printf + "<LI><INPUT TYPE=CHECKBOX NAME=%#a VALUE=%#a%s> %s\\n" + (html:atval pname) (html:atval value) + (if (member value default-list) " CHECKED" "") + (html:plain value))) + value-list))) + (html:printf "</MENU>")) + +;;@body The symbol @1 is either @code{get}, @code{head}, @code{post}, +;;@code{put}, or @code{delete}. @0 prints the header for an HTML +;;@dfn{form}. +(define (html:start-form method action) + (cond ((not (memq method '(get head post put delete))) + (slib:error 'html:start-form "method unknown:" method))) + (html:printf "<FORM METHOD=%#a ACTION=%#a>\\n" + (html:atval method) (html:atval action)) + (html:printf "<DL>\\n")) + +;;@body @0 prints the footer for an HTML @dfn{form}. The string @2 +;;appears on the button which submits the form. +(define (html:end-form pname submit-label) + (html:printf "</DL>\\n") + (html:printf "<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a> <INPUT TYPE=RESET>\\n" + (html:atval '*command*) (html:atval submit-label)) + (html:printf "</FORM><HR>\\n")) + +;;@body Outputs headers for an HTML page named @1. +(define (html:start-page title) + (html:printf "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\\n") + (html:comment) + (html:printf "<HEAD><TITLE>%s</TITLE></HEAD>\\n" (html:plain title)) + (html:printf "<BODY><H1>%s</H1>\\n" (html:plain title))) + +;;@body Outputs HTML codes to end a page. +(define (html:end-page) + (html:printf "</BODY>\\n")) + +(define (html:generate-form comname method action docu pnames docs aliases + arities types default-lists value-lists) + (define aliast (map list pnames)) + (for-each (lambda (alias) (if (> (string-length (car alias)) 1) + (let ((apr (assq (cadr alias) aliast))) + (set-cdr! apr (cons (car alias) (cdr apr)))))) + aliases) + (dynamic-wind + (lambda () + (html:printf "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n" + (html:plain comname) (html:plain docu)) + (html:start-form 'post action)) + (lambda () + (for-each + (lambda (pname doc aliat arity default-list value-list) + (define longname + (remove-if (lambda (s) (= 1 (string-length s))) (cdr aliat))) + (set! longname (if (null? longname) #f (car longname))) + (cond (longname + (case (length value-list) + ((0) (case arity + ((boolean) (html:checkbox longname doc pname 'Y)) + ((single optional) + (html:text longname doc pname + (if (null? default-list) + #f (car default-list)))) + (else + (html:text-area longname doc pname default-list)))) + ((1) (html:checkbox longname doc pname (car value-list))) + (else ((case arity + ((single optional) html:select) + (else html:buttons)) + longname doc pname arity default-list value-list)))))) + pnames docs aliast arities default-lists value-lists)) + (lambda () + (html:end-form comname comname)))) + +;;@body The symbol @2 names a command table in the @1 relational +;;database. +;; +;;@0 writes an HTML-2.0 @dfn{form} for command @3 to the +;;current-output-port. The @samp{SUBMIT} button, which is labeled @3, +;;invokes the URI @5 with method @4 with a hidden attribute +;;@code{*command*} bound to the command symbol submitted. +;; +;;An action may invoke a CGI script +;;(@samp{http://www.my-site.edu/cgi-bin/search.cgi}) or HTTP daemon +;;(@samp{http://www.my-site.edu:8001}). +;; +;;This example demonstrates how to create a HTML-form for the @samp{build} +;;command. +;; +;;@example +;;(require (in-vicinity (implementation-vicinity) "build.scm")) +;;(call-with-output-file "buildscm.html" +;; (lambda (port) +;; (fluid-let ((*html:output-port* port)) +;; (html:start-page 'commands) +;; (command->html +;; build '*commands* 'build 'post +;; (or "/cgi-bin/build.cgi" +;; "http://localhost:8081/buildscm")) +;; html:end-page))) +;;@end example +(define (command->html rdb command-table command method action) + (define rdb-open (rdb 'open-table)) + (define (row-refer idx) (lambda (row) (list-ref row idx))) + (let ((comtab (rdb-open command-table #f)) + (domain->type ((rdb-open '*domains-data* #f) 'get 'type-id)) + (get-domain-choices + (let ((for-tab-name + ((rdb-open '*domains-data* #f) 'get 'foreign-table))) + (lambda (domain-name) + (define tab-name (for-tab-name domain-name)) + (if tab-name + (do ((dlst (((rdb-open tab-name #f) 'get* 1)) (cdr dlst)) + (out '() (if (member (car dlst) (cdr dlst)) + out (cons (car dlst) out)))) + ((null? dlst) out)) + '()))))) + (define row-ref + (let ((names (comtab 'column-names))) + (lambda (row name) (list-ref row (position name names))))) + (let* ((command:row ((comtab 'row:retrieve) command)) + (parameter-table (rdb-open (row-ref command:row 'parameters) #f)) + (pcnames (parameter-table 'column-names)) + (param-rows (sort! ((parameter-table 'row:retrieve*)) + (lambda (r1 r2) (< (car r1) (car r2)))))) + (let ((domains (map (row-refer (position 'domain pcnames)) param-rows)) + (parameter-names + (rdb-open (row-ref command:row 'parameter-names) #f))) + (html:generate-form + command + method + action + (row-ref command:row 'documentation) + (map (row-refer (position 'name pcnames)) param-rows) + (map (row-refer (position 'documentation pcnames)) param-rows) + (map list ((parameter-names 'get* 'name)) + (map (parameter-table 'get 'name) + ((parameter-names 'get* 'parameter-index)))) + (map (row-refer (position 'arity pcnames)) param-rows) + (map domain->type domains) + (map cdr (fill-empty-parameters + (map slib:eval + (map (row-refer (position 'defaulter pcnames)) + param-rows)) + (make-parameter-list + (map (row-refer (position 'name pcnames)) param-rows)))) + (map get-domain-choices domains)))))) + +(define (cgi:process-% str) + (define len (string-length str)) + (define (sub str) + (cond + ((string-index str #\%) + => (lambda (idx) + (if (and (< (+ 2 idx) len) + (string->number (substring str (+ 1 idx) (+ 2 idx)) 16) + (string->number (substring str (+ 2 idx) (+ 3 idx)) 16)) + (string-append + (substring str 0 idx) + (string (integer->char + (string->number + (substring str (+ 1 idx) (+ 3 idx)) + 16))) + (sub (substring str (+ 3 idx) (string-length str))))))) + (else str))) + (sub str)) + +(define (form:split-lines txt) + (let ((idx (string-index txt #\newline)) + (carriage-return (integer->char #xd))) + (if idx + (cons (substring txt 0 + (if (and (positive? idx) + (char=? carriage-return + (string-ref txt (+ -1 idx)))) + (+ -1 idx) + idx)) + (form:split-lines + (substring txt (+ 1 idx) (string-length txt)))) + (list txt)))) + +(define (form-urlencoded->query-alist txt) + (if (symbol? txt) (set! txt (symbol->string txt))) + (set! txt (string-subst txt " " "" "+" " ")) + (do ((lst '()) + (edx (string-index txt #\=) + (string-index txt #\=))) + ((not edx) lst) + (let* ((rxt (substring txt (+ 1 edx) (string-length txt))) + (adx (string-index rxt #\&)) + (name (cgi:process-% (substring txt 0 edx)))) + (set! + lst (append + lst + (map + (lambda (value) (list (string->symbol name) + (if (equal? "" value) #f value))) + (form:split-lines + (cgi:process-% (substring rxt 0 (or adx (string-length rxt)))))))) + (set! txt (if adx (substring rxt (+ 1 adx) (string-length rxt)) ""))))) + +(define (query-alist->parameter-list alist optnames arities types) + (define (can-take-arg? opt) + (not (eq? (list-ref arities (position opt optnames)) 'boolean))) + (let ((parameter-list (make-parameter-list optnames))) + (for-each + (lambda (lst) + (let* ((value (cadr lst)) + (name (car lst))) + (cond ((not (can-take-arg? name)) + (adjoin-parameters! parameter-list (list name #t))) + (value + (adjoin-parameters! + parameter-list + (let ((type (list-ref types (position name optnames)))) + (case type + ((expression) (list name value)) + ((symbol) + (if (string? value) + (call-with-input-string + value + (lambda (port) + (do ((tok (scanf-read-list " %s" port) + (scanf-read-list " %s" port)) + (lst '() + (cons (string-ci->symbol (car tok)) + lst))) + ((or (null? tok) (eof-object? tok)) + (cons name lst))))) + (list name (coerce value type)))) + (else (list name (coerce value type)))))))))) + alist) + parameter-list)) + +;;@c node HTTP and CGI service, Printing Scheme, HTML Forms, Textual Conversion Packages +;;@section HTTP and CGI service + +;;@code{(require 'html-form)} + +;;;; Now that we have generated the HTML form, process the ensuing CGI request. + +;;@body Reads a @samp{"POST"} or @samp{"GET"} query from +;;@code{(current-input-port)} and executes the encoded command from @2 +;;in relational-database @1. +;; +;;This example puts up a plain-text page in response to a CGI query. +;; +;;@example +;;(display "Content-Type: text/plain") (newline) (newline) +;;(require 'html-form) +;;(load (in-vicinity (implementation-vicinity) "build.scm")) +;;(cgi:serve-command build '*commands*) +;;@end example +(define (cgi:serve-command rdb command-table) + (serve-urlencoded-command rdb command-table (cgi:read-query-string))) + +;;@body Reads attribute-value pairs from @3, converts them to +;;parameters and invokes the @1 command named by the parameter +;;@code{*command*}. +(define (serve-urlencoded-command rdb command-table urlencoded) + (let* ((alist (form-urlencoded->query-alist urlencoded)) + (comname #f) + (comtab ((rdb 'open-table) command-table #f)) + (names (comtab 'column-names)) + (row-ref (lambda (row name) (list-ref row (position name names)))) + (comgetrow (comtab 'row:retrieve))) + (set! alist (remove-if (lambda (elt) + (cond ((not (and (list? elt) (pair? elt) + (eq? '*command* (car elt)))) #f) + (comname + (slib:error + 'serve-urlencoded-command + 'more-than-one-command? comname + (string->symbol (cadr elt)))) + (else (set! comname + (string-ci->symbol (cadr elt))) + #t))) + alist)) + (let* ((command:row (comgetrow comname)) + (parameter-table ((rdb 'open-table) + (row-ref command:row 'parameters) #f)) + (comval ((slib:eval (row-ref command:row 'procedure)) rdb)) + (options ((parameter-table 'get* 'name))) + (positions ((parameter-table 'get* 'index))) + (arities ((parameter-table 'get* 'arity))) + (defaulters (map slib:eval ((parameter-table 'get* 'defaulter)))) + (domains ((parameter-table 'get* 'domain))) + (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id) + domains)) + (dirs (map (rdb 'domain-checker) domains))) + + (let* ((params (query-alist->parameter-list alist options arities types)) + (fparams (fill-empty-parameters defaulters params))) + (and (list? fparams) (check-parameters dirs fparams) + (comval fparams)))))) + +(define (serve-query-alist-command rdb command-table alist) + (let ((command #f)) + (set! alist (remove-if (lambda (elt) + (cond ((not (and (list? elt) (pair? elt) + (eq? '*command* (car elt)))) #f) + (command + (slib:error + 'serve-query-alist-command + 'more-than-one-command? command + (string->symbol (cadr elt)))) + (else (set! command + (string-ci->symbol (cadr elt))) + #t))) + alist)) + ((make-command-server rdb command-table) + command + (lambda (comname comval options positions + arities types defaulters dirs aliases) + (let* ((params (query-alist->parameter-list alist options arities types)) + (fparams (fill-empty-parameters defaulters params))) + (and (list? fparams) (check-parameters dirs fparams) + (apply comval + (parameter-list->arglist positions arities fparams)))))))) + +(define http:crlf (string (integer->char 13) #\newline)) +(define (http:read-header port) + (define alist '()) + (do ((line (read-line port) (read-line port))) + ((or (zero? (string-length line)) + (and (= 1 (string-length line)) + (char-whitespace? (string-ref line 0))) + (eof-object? line)) + (if (and (= 1 (string-length line)) + (char-whitespace? (string-ref line 0))) + (set! http:crlf (string (string-ref line 0) #\newline))) + (if (eof-object? line) line alist)) + (let ((len (string-length line)) + (idx (string-index line #\:))) + (if (char-whitespace? (string-ref line (+ -1 len))) + (set! len (+ -1 len))) + (and idx (do ((idx2 (+ idx 1) (+ idx2 1))) + ((or (>= idx2 len) + (not (char-whitespace? (string-ref line idx2)))) + (set! alist + (cons + (cons (string-ci->symbol (substring line 0 idx)) + (substring line idx2 len)) + alist))))) + ;;Else -- ignore malformed line + ;;(else (slib:error 'http:read-header 'malformed-input line)) + ))) + +(define (http:read-query-string request-line header port) + (case (car request-line) + ((get head) + (let* ((request-uri (cadr request-line)) + (len (string-length request-uri))) + (and (> len 3) + (string-index request-uri #\?) + (substring request-uri + (+ 1 (string-index request-uri #\?)) + (if (eqv? #\/ (string-ref request-uri (+ -1 len))) + (+ -1 len) + len))))) + ((post put delete) + (let ((content-length (assq 'content-length header))) + (and content-length + (set! content-length (string->number (cdr content-length)))) + (and content-length + (let ((str (make-string content-length #\ ))) + (do ((idx 0 (+ idx 1))) + ((>= idx content-length) + (if (>= idx (string-length str)) str (substring str 0 idx))) + (let ((chr (read-char port))) + (if (char? chr) + (string-set! str idx chr) + (set! content-length idx)))))))) + (else #f))) + +(define (http:send-status-line status-code reason) + (html:printf "HTTP/1.1 %d %s%s" status-code reason http:crlf)) +(define (http:send-header alist) + (for-each (lambda (pair) + (html:printf "%s: %s%s" (car pair) (cdr pair) http:crlf)) + alist) + (html:printf http:crlf)) + +(define *http:byline* + "<A HREF=http://swissnet.ai.mit.edu/~jaffer/SLIB.html>SLIB </A>HTTP/1.1 server") + +(define (http:send-error-page code str port) + (fluid-let ((*html:output-port* port)) + (http:send-status-line code str) + (http:send-header '(("Content-Type" . "text/html"))) + (html:start-page (sprintf #f "%d %s" code str)) + (and *http:byline* (html:printf "<HR>\\n%s\\n" *http:byline*)) + (html:end-page))) + +;;@body reads the @dfn{query-string} from @1. If this is a valid +;;@samp{"POST"} or @samp{"GET"} query, then @0 calls @3 with two +;;arguments, the query-string and the header-alist. +;; +;;Otherwise, @0 replies (to @2) with appropriate HTML describing the +;;problem. +(define (http:serve-query input-port output-port serve-proc) + (let ((request-line (http:read-request-line input-port))) + (cond ((not request-line) + (http:send-error-page 400 "Bad Request" output-port)) + ((string? (car request-line)) + (http:send-error-page 501 "Not Implemented" output-port)) + ((not (case (car request-line) + ((get post) #t) + (else #f))) + (http:send-error-page 405 "Method Not Allowed" output-port)) + (else (let* ((header (http:read-header input-port)) + (query-string + (http:read-query-string + request-line header input-port))) + (cond ((not query-string) + (http:send-error-page 400 "Bad Request" output-port)) + (else (http:send-status-line 200 "OK") + (serve-proc query-string header)))))))) + +;;@ This example services HTTP queries from port 8081: +;; +;;@example +;;(define socket (make-stream-socket AF_INET 0)) +;;(socket:bind socket 8081) +;;(socket:listen socket 10) +;;(dynamic-wind +;; (lambda () #f) +;; (lambda () +;; (do ((port (socket:accept socket) +;; (socket:accept socket))) +;; (#f) +;; (dynamic-wind +;; (lambda () #f) +;; (lambda () +;; (fluid-let ((*html:output-port* port)) +;; (http:serve-query +;; port port +;; (lambda (query-string header) +;; (http:send-header +;; '(("Content-Type" . "text/plain"))) +;; (with-output-to-port port +;; (lambda () +;; (serve-urlencoded-command +;; build '*commands* query-string))))))) +;; (lambda () (close-port port))))) +;; (lambda () (close-port socket))) +;;@end example + +(define (http:read-start-line port) + (do ((line (read-line port) (read-line port))) + ((or (not (equal? "" line)) (eof-object? line)) line))) + +;;@body Reads the first non-blank line from @1 and, if successful, +;;returns a list of three itmes from the request-line: +;; +;;@enumerate 0 +;; +;;@item Method +;; +;;Either one of the symbols @code{options}, @code{get}, @code{head}, +;;@code{post}, @code{put}, @code{delete}, or @code{trace}; Or a string. +;; +;;@item Request-URI +;; +;;A string. At the minimum, it will be the string @samp{"/"}. +;; +;;@item HTTP-Version +;; +;;A string. For example, @samp{HTTP/1.0}. +;;@end enumerate +(define (http:read-request-line port) + (let ((lst (scanf-read-list "%s %s %s %s" (http:read-start-line port)))) + (and (list? lst) + (= 3 (length lst)) + (let ((method + (assoc + (car lst) + '(("OPTIONS" . options) ; Section 9.2 + ("GET" . get) ; Section 9.3 + ("HEAD" . head) ; Section 9.4 + ("POST" . post) ; Section 9.5 + ("PUT" . put) ; Section 9.6 + ("DELETE" . delete) ; Section 9.7 + ("TRACE" . trace) ; Section 9.8 + )))) + (cons (if (pair? method) (cdr method) (car lst)) (cdr lst)))))) + +;;@body Reads the @dfn{query-string} from @code{(current-input-port)}. +;;@0 reads a @samp{"POST"} or @samp{"GET"} queries, depending on the +;;value of @code{(getenv "REQUEST_METHOD")}. +(define (cgi:read-query-string) + (define request-method (getenv "REQUEST_METHOD")) + (cond ((and request-method (string-ci=? "GET" request-method)) + (getenv "QUERY_STRING")) + ((and request-method (string-ci=? "POST" request-method)) + (let ((content-length (getenv "CONTENT_LENGTH"))) + (and content-length + (set! content-length (string->number content-length))) + (and content-length + (let ((str (make-string content-length #\ ))) + (do ((idx 0 (+ idx 1))) + ((>= idx content-length) + (if (>= idx (string-length str)) + str + (substring str 0 idx))) + (let ((chr (read-char))) + (if (char? chr) + (string-set! str idx chr) + (set! content-length idx)))))))) + (else #f))) diff --git a/logical.scm b/logical.scm index 1cc0726..c85507d 100644 --- a/logical.scm +++ b/logical.scm @@ -67,10 +67,25 @@ (define (logical:logbit? index int) (logical:logtest (logical:integer-expt 2 index) int)) -(define (logical:bit-extract n start end) +(define (logical:copy-bit index to bool) + (if bool + (logical:logior to (logical:ash 1 index)) + (logical:logand to (logical:lognot (logical:ash 1 index))))) + +(define (logical:bit-field n start end) (logical:logand (- (logical:integer-expt 2 (- end start)) 1) (logical:ash n (- start)))) +(define (logical:bitwise-if mask n0 n1) + (logical:logior (logical:logand mask n0) + (logical:logand (logical:lognot mask) n1))) + +(define (logical:copy-bit-field to start end from) + (logical:bitwise-if + (logical:ash (- (logical:integer-expt 2 (- end start)) 1) start) + (logical:ash from start) + to)) + (define (logical:ash int cnt) (if (negative? cnt) (let ((n (logical:integer-expt 2 (- cnt)))) @@ -142,9 +157,12 @@ (define lognot logical:lognot) (define logtest logical:logtest) (define logbit? logical:logbit?) +(define copy-bit logical:copy-bit) (define ash logical:ash) (define logcount logical:logcount) (define integer-length logical:integer-length) -(define bit-extract logical:bit-extract) +(define bit-field logical:bit-field) +(define bit-extract logical:bit-field) +(define copy-bit-field logical:copy-bit-field) (define ipow-by-squaring logical:ipow-by-squaring) (define integer-expt logical:integer-expt) diff --git a/macscheme.init b/macscheme.init index 281bcec..58927ee 100644 --- a/macscheme.init +++ b/macscheme.init @@ -88,7 +88,6 @@ ; 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 @@ -164,8 +163,7 @@ ;;; Return argument (define (identity x) x) -;;; If your implementation provides eval SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) ;;; If your implementation provides R4RS macros: @@ -76,7 +76,7 @@ `(lambda (port) (define crc 0) (define byte-count 0) - (define crctab ,crctab) + (define crctab ',crctab) (do ((ci (read-char port) (read-char port))) ((eof-object? ci)) ,(accum '(char->integer ci)) diff --git a/mitscheme.init b/mitscheme.init index 9486c18..bd612b0 100644 --- a/mitscheme.init +++ b/mitscheme.init @@ -19,8 +19,10 @@ ;;; Make this part of your ~/.scheme.init file. +(define getenv get-environment-variable) + ;;; (software-type) should be set to the generic operating system type. -(define (software-type) 'UNIX) +(define (software-type) (if (getenv "HOMEDRIVE") 'MS-DOS 'UNIX)) ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. @@ -30,16 +32,14 @@ ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. -(define (scheme-implementation-version) "7.3.0") - -;;; *features* should be set to a list of symbols describing features -;;; of this implementation. See Template.scm for the list of feature -;;; names. - -;the following may not be the Right Thing for this application, since -;it causes an error (rather than just returning nil) when the environment -;variable is not defined. -(define getenv get-environment-variable) +(define (scheme-implementation-version) + (let* ((str (with-output-to-string identify-world)) + (beg (+ (substring? "Release " str) 8)) + (rst (substring str beg (string-length str))) + (end (string-find-next-char-in-set + rst + (predicate->char-set char-whitespace?)))) + (substring rst 0 end))) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme @@ -47,7 +47,8 @@ (define (implementation-vicinity) (case (software-type) - ((UNIX) "/usr/local/src/scheme/") + ((MS-DOS) "c:\\scheme\\") + ((UNIX) "/usr/local/lib/mit-scheme/") ((VMS) "scheme$src:"))) ;;; (library-vicinity) should be defined to be the pathname of the @@ -58,9 +59,9 @@ (or (getenv "SCHEME_LIBRARY_PATH") ;; Use this path if your scheme does not support GETENV. (case (software-type) + ((MS-DOS) "c:\\slib\\") ((UNIX) "/usr/local/lib/slib/") ((VMS) "lib$scheme:") - ((MS-DOS) "C:\\SLIB\\") (else ""))))) (lambda () library-path))) @@ -72,6 +73,10 @@ (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 @@ -103,6 +108,7 @@ pretty-print object->string trace ;has macros: TRACE and UNTRACE + defmacro compiler getenv Xwindows @@ -165,8 +171,7 @@ ;;; Return argument (define (identity x) x) -;;; If your implementation provides eval, SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. ;(define (slib:eval form) (eval form (repl/environment (nearest-repl)))) (define (slib:eval form) (eval form user-initial-environment)) @@ -253,7 +258,7 @@ ;;; Here for backward compatability -(define (scheme-file-suffix) "") +(define (scheme-file-suffix) ".scm") ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;; suffix all the module files in SLIB have. See feature 'SOURCE. @@ -270,4 +275,4 @@ (define slib:load slib:load-source) -(slib:load (in-vicinity (library-vicinity) "require")) +(slib:load (in-vicinity (library-vicinity) "require.scm")) diff --git a/mklibcat.scm b/mklibcat.scm index 050a3ba..dbc26d9 100644 --- a/mklibcat.scm +++ b/mklibcat.scm @@ -90,7 +90,7 @@ (qp . "qp") (break defmacro . "break") (trace defmacro . "trace") - ;;(eval . "eval") + (eval . "eval") (record . "record") (promise . "promise") (synchk . "synchk") @@ -99,7 +99,7 @@ (syntax-case . "scainit") (syntactic-closures . "scmacro") (macros-that-work . "macwork") - (macro . macros-that-work) + (macro . macro-by-example) (yasos macro . "yasos") (oop . yasos) (collect macro . "collect") @@ -119,10 +119,14 @@ (relational-database . "rdms") (database-utilities . "dbutil") (database-browse . "dbrowse") + (html-form . "htmlform") (alist-table . "alistab") (parameters . "paramlst") + (getopt-parameters . "getparam") (read-command . "comparse") (batch . "batch") + (glob . "glob") + (filename . glob) (make-crc . "makcrc") (wt-tree . "wttree") (string-search . "strsrch") @@ -134,6 +138,7 @@ (determinant . "determ") (byte . "byte") (tzfile . "tzfile") + (schmooz . "schmooz") (new-catalog . "mklibcat") )))) (display " " op) @@ -145,11 +150,14 @@ (newline op) (display ")" op) (newline op) - (let ((mkimpcat (in-vicinity (implementation-vicinity) "mkimpcat"))) - (cond ((not (file-exists? mkimpcat)) - (set! mkimpcat (string-append mkimpcat (scheme-file-suffix))))) - (cond ((file-exists? mkimpcat) - (slib:load-source mkimpcat)))) + (let ((load-if-exists + (lambda (path) + (cond ((not (file-exists? path)) + (set! path (string-append path (scheme-file-suffix))))) + (cond ((file-exists? path) + (slib:load-source path)))))) + ;;(load-if-exists (in-vicinity (implementation-vicinity) "mksitcat")) + (load-if-exists (in-vicinity (implementation-vicinity) "mkimpcat"))) (let ((catcat (lambda (vicinity name specificity) diff --git a/mwdenote.scm b/mwdenote.scm index c3fe5f3..def1d4d 100644 --- a/mwdenote.scm +++ b/mwdenote.scm @@ -42,6 +42,7 @@ (set! . (special set!)) (begin . (special begin)) (define . (special define)) + (case . (special case)) ;; @@ added wdc (let . (special let)) ;; @@ added KAD (let* . (special let*)) ;; @@ " (letrec . (special letrec)) ;; @@ " @@ -150,6 +151,9 @@ (define mw:denote-of-::: (mw:syntax-lookup mw:standard-syntax-environment ':::)) +(define mw:denote-of-case + (mw:syntax-lookup mw:standard-syntax-environment 'case)) ;; @@ wdc + (define mw:denote-of-let (mw:syntax-lookup mw:standard-syntax-environment 'let)) ;; @@ KenD @@ -200,23 +204,35 @@ ; Given a datum, strips the suffixes from any symbols that appear within ; the datum, trying not to copy any more of the datum than necessary. -; Well, right now I'm just copying the datum, but I need to fix that! - -(define (mw:strip x) - (cond ((symbol? x) - (let ((chars (memv mw:suffix-character - (reverse (string->list - (symbol->string x)))))) - (if chars - (string->symbol - (list->string (reverse (cdr chars)))) - x))) - ((pair? x) - (cons (mw:strip (car x)) - (mw:strip (cdr x)))) - ((vector? x) - (list->vector (map mw:strip (vector->list x)))) - (else x))) + +; @@ rewrote to strip *all* suffixes -- wdc + +(define mw:strip + (letrec ((original-symbol + (lambda (x) + (let ((s (symbol->string x))) + (loop x s 0 (string-length s))))) + (loop + (lambda (sym s i n) + (cond ((= i n) sym) + ((char=? (string-ref s i) + mw:suffix-character) + (string->symbol (substring s 0 i))) + (else + (loop sym s (+ i 1) n)))))) + (lambda (x) + (cond ((symbol? x) + (original-symbol x)) + ((pair? x) + (let ((y (mw:strip (car x))) + (z (mw:strip (cdr x)))) + (if (and (eq? y (car x)) + (eq? z (cdr x))) + x + (cons y z)))) + ((vector? x) + (list->vector (map mw:strip (vector->list x)))) + (else x))))) ; Given a list of identifiers, returns an alist that associates each ; identifier with a fresh identifier. diff --git a/mwexpand.scm b/mwexpand.scm index 10083a3..a53f0da 100644 --- a/mwexpand.scm +++ b/mwexpand.scm @@ -146,6 +146,8 @@ ((eq? keyword mw:denote-of-let-syntax) (mw:let-syntax exp env)) ((eq? keyword mw:denote-of-letrec-syntax) (mw:letrec-syntax exp env)) + ; @@ case has a nontrivial syntax also -- wdc + ((eq? keyword mw:denote-of-case) (mw:case exp env)) ; @@ let, let*, letrec, paint within quasiquotation -- kend ((eq? keyword mw:denote-of-let) (mw:let exp env)) ((eq? keyword mw:denote-of-let*) (mw:let* exp env)) @@ -394,6 +396,21 @@ exp) ) +; CASE -- added by wdc +(define (mw:case exp env) + (let ((expand (lambda (exp) + (mw:expand exp env)))) + (if (< (mw:safe-length exp) 3) + (mw:error "Malformed case expression" exp env) + `(case ,(expand (cadr exp)) + ,@(map (lambda (clause) + (if (< (mw:safe-length exp) 2) + (mw:error "Malformed case clause" exp env) + (cons (mw:strip (car clause)) + (map expand (cdr clause))))) + (cddr exp)))))) + + ; LET (define (mw:let exp env) (let* ( (name (if (or (pair? (cadr exp)) (null? (cadr exp))) diff --git a/obj2str.scm b/obj2str.scm index 19d8464..a8445f6 100644 --- a/obj2str.scm +++ b/obj2str.scm @@ -19,6 +19,7 @@ (require 'string-port) +;;@body Returns the textual representation of @1 as a string. (define (object->string obj) (cond ((symbol? obj) (symbol->string obj)) ((number? obj) (number->string obj)) @@ -43,6 +44,8 @@ ; (object->limited-string obj limit) returns a string containing the first ; 'limit' characters of the textual representation of 'obj'. +;;@body Returns the textual representation of @1 as a string of length +;;at most @2. (define (object->limited-string obj limit) (require 'generic-write) (let ((result '()) (left limit)) diff --git a/paramlst.scm b/paramlst.scm index 706c91c..b4af55a 100644 --- a/paramlst.scm +++ b/paramlst.scm @@ -52,15 +52,14 @@ defaulters parameter-list)) (define (check-parameters checks parameter-list) - (for-each (lambda (check parameter) - (for-each - (lambda (p) - (cond ((and check (not (check p))) - (slib:error (car parameter) - "parameter is wrong type: " p)))) - (cdr parameter))) - checks parameter-list) - parameter-list) + (and (every (lambda (check parameter) + (every + (lambda (p) + (not (and check (not (check p))))) + ;;(slib:error (car parameter) "parameter is wrong type: " p) + (cdr parameter))) + checks parameter-list) + parameter-list)) (define (check-arities arity-specs parameter-list) (and (every identity arity-specs) @@ -128,136 +127,3 @@ (set-cdr! apair (cons #t (cdr apair))))))) apairs parameters) parameter-list))) - -(define (getopt->parameter-list argc argv optnames arities types aliases) - (define (can-take-arg? opt) - (not (eq? (list-ref arities (position opt optnames)) - 'boolean))) - (define (coerce-val val curopt) - (define ntyp (list-ref types (position curopt optnames))) - (case ntyp - ((expression) val) - (else (coerce val ntyp)))) - (require 'getopt) - (let ((starting-optind *optind*) - (optlist '()) - (long-opt-list '()) - (optstring #f) - (parameter-list (make-parameter-list optnames)) - (curopt '*unclaimed-argument*)) - (set! aliases (map (lambda (alias) - (define str (string-copy (car alias))) - (do ((i (+ -1 (string-length str)) (+ -1 i))) - ((negative? i) (cons str (cdr alias))) - (cond ((char=? #\ (string-ref str i)) - (string-set! str i #\-))))) - aliases)) - (for-each - (lambda (alias) - (define opt (car alias)) - (cond ((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 - ((#\: #\?) - (let ((aliast (map list optnames)) - (strlen=1? (lambda (s) (= 1 (string-length s)))) - (cep (current-error-port))) - (require 'printf) - (require 'common-list-functions) - (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 ...] ..." - (list-ref argv (+ -1 starting-optind))) - (newline cep) (newline cep) - (for-each - (lambda (optname arity aliat) - (let loop ((initials (remove-if-not strlen=1? (cdr aliat))) - (longname (remove-if strlen=1? (cdr aliat)))) - (cond ((and (null? initials) (null? longname))) - (else - (fprintf cep - (case arity - ((boolean) " %3s %s") - (else " %3s %s<%s> %s")) - (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 ""))) - (newline cep) - (loop (if (null? initials) '() (cdr initials)) - (if (null? longname) '() (cdr longname))))))) - optnames arities aliast)) - (slib:error 'getopt->parameter-list - (case opt - ((#\:) "argument missing after") - ((#\?) "unrecognized option")) - (string #\- getopt:opt))) - ((#f) - (cond ((and (< *optind* argc) - (string=? "-" (list-ref argv *optind*))) - (set! *optind* (+ 1 *optind*))) - ((< *optind* argc) - (cond ((and (member curopt optnames) - (adjoin-parameters! - parameter-list - (list curopt - (coerce-val (list-ref argv *optind*) - curopt)))) - (set! *optind* (+ 1 *optind*)) - (loop)) - (else (slib:error 'getopt->parameter-list curopt - (list-ref argv *optind*) - "not supported")))))) - (else - (cond ((char? opt) (set! opt (string opt)))) - (let ((topt (assoc opt aliases))) - (cond (topt (set! topt (cadr topt))) - (else (slib:error "Option not recognized -" opt))) - (cond - ((not (can-take-arg? topt)) - (adjoin-parameters! parameter-list (list topt #t))) - (*optarg* - (set! curopt topt) - (adjoin-parameters! parameter-list - (list topt (coerce-val *optarg* curopt)))) - (else - (set! curopt topt) -;;; (slib:warn 'getopt->parameter-list -;;; "= missing for option--" opt) - ))) - (loop))))) - parameter-list)) - -(define (getopt->arglist argc argv optnames positions - arities types defaulters checks aliases) - (let* ((params (getopt->parameter-list - argc argv optnames arities types aliases)) - (fparams (fill-empty-parameters defaulters params))) - (and (list? params) (check-parameters checks fparams)) - (and (list? params) (parameter-list->arglist positions arities fparams)))) @@ -72,7 +72,7 @@ (cond ((eqv? #\newline (tok:peek-char)) (tok:read-char))) ;to do newline (set! tok:column (+ tok:column pos))))) -(define (prec:warn msg) +(define (prec:warn . msgs) (do ((j (+ -1 tok:column) (+ -8 j))) ((> 8 j) (do ((i j (+ -1 i))) @@ -80,7 +80,8 @@ (display #\ ))) (display slib:tab)) (display "^ ") - (display msg) + (newline) + (for-each (lambda (x) (write x) (display #\ )) msgs) (newline)) ;; Structure of lexical records. @@ -189,9 +190,10 @@ (define (prec:delim tk) (prec:make-led tk 0 #f)) -(define (prec:nofix tk sop) - (prec:make-nud tk prec:parse-nofix sop)) -(define (prec:parse-nofix self sop) +(define (prec:nofix tk sop . binds) + (prec:make-nud tk prec:parse-nofix sop (apply append binds))) +(define (prec:parse-nofix self sop binds) + (set! *syn-rules* (prec:process-binds binds *syn-rules*)) (prec:call-or-list (or sop (prec:symbolfy self)))) (define (prec:prefix tk sop bp . binds) @@ -212,9 +214,10 @@ (prec:apply-or-cons (or sop (prec:symbolfy self)) (cons left (prec:parse-list self bp)))) -(define (prec:postfix tk sop lbp) - (prec:make-led tk lbp prec:parse-postfix sop)) -(define (prec:parse-postfix left self lbp sop) +(define (prec:postfix tk sop lbp . binds) + (prec:make-led tk lbp prec:parse-postfix sop (apply append binds))) +(define (prec:parse-postfix left self lbp sop binds) + (set! *syn-rules* (prec:process-binds binds *syn-rules*)) (prec:call-or-list (or sop (prec:symbolfy self)) left)) (define (prec:prestfix tk sop bp . binds) @@ -269,9 +272,12 @@ (cond ((equal? (force prec:token) match) (prec:advance)) ((prec:delim? (force prec:token)) - (prec:warn 'mismatched-delimiter) + (prec:warn 'mismatched-delimiter (force prec:token) + 'not match) (prec:advance)) - (else (prec:warn 'delimiter-expected--ignoring-rest) + (else (prec:warn 'delimiter-expected--ignoring-rest + (force prec:token) 'expected match + 'or-delimiter) (do () ((prec:delim? (force prec:token))) (prec:parse1 0)))) ans))))) @@ -356,15 +362,18 @@ (cons '? (prec:parse-delimited sep delim))) ((prec:delim? (force prec:token)) (if (not (equal? (force prec:token) delim)) - (prec:warn 'mismatched-delimiter)) + (prec:warn 'mismatched-delimiter (force prec:token) + 'expected delim)) (if (not sep) (prec:warn 'expression-missing)) (prec:advance) (if sep '() '(?))) (else (let ((ans (prec:parse-list sep bp))) (cond ((equal? (force prec:token) delim)) ((prec:delim? (force prec:token)) - (prec:warn 'mismatched-delimiter)) - (else (prec:warn 'delimiter-expected--ignoring-rest) + (prec:warn 'mismatched-delimiter (force prec:token) + 'expecting delim)) + (else (prec:warn 'delimiter-expected--ignoring-rest + (force prec:token) '...) (do () ((prec:delim? (force prec:token))) (prec:parse1 bp)))) (prec:advance) @@ -381,7 +390,8 @@ (let ((ans (prec:parse1 0))) (cond ((eof-object? (force prec:token))) ((equal? (force prec:token) delim)) - (else (prec:warn 'delimiter-expected--ignoring-rest) + (else (prec:warn 'delimiter-expected--ignoring-rest + (force prec:token) 'not delim) (do () ((or (equal? (force prec:token) delim) (eof-object? (force prec:token)))) (prec:advance)))) @@ -85,23 +85,26 @@ ;; Is `n' Divisible By a Small Prime? ;; -(define (primes:dbsp? n) - (let ((limit (min (sqrt n) primes:max-small-prime)) - (divisible #f) - ) - (do ((i 0 (1+ i))) - ((let* ((divisor (vector-ref primes:small-primes i))) - (set! divisible (= (modulo n divisor) 0)) - (or divisible (>= divisor limit))) - divisible) - ))) +(define primes:dbsp? + (let ((sqrt (cond ((provided? 'inexact) sqrt) + (else (require 'root) integer-sqrt)))) + (lambda (n) + (let ((limit (min (sqrt n) primes:max-small-prime)) + (divisible #f) + ) + (do ((i 0 (1+ i))) + ((let* ((divisor (vector-ref primes:small-primes i))) + (set! divisible (= (modulo n divisor) 0)) + (or divisible (> divisor limit))) + divisible) + ))))) ;; Does `n' pass the R.-M. primality test for `m' random numbers? ;; (define (primes:rm-prime? n m) (do ((i 0 (1+ i)) - (x (+ 2 (random (- n 2))))) + (x (+ 2 (random (- n 2) primes:prngs)))) ((or (= i m) (primes:rm-composite? n x)) (= i m)))) @@ -150,6 +153,9 @@ (set! y (modulo (* y z) modulus))) )) +(define primes:prngs + (make-random-state "repeatable seed for primes")) + ;; This table seems big enough so that making it larger really ;; doesn't have much effect. ;; @@ -19,14 +19,136 @@ (require 'string-case) -;;; Floating point is not handled yet. +;; Parse the output of NUMBER->STRING. +;; Returns a list: (sign-character digit-string exponent-integer) +;; sign-char will be either #\+ or #\-, digit-string will always begin +;; with a "0", after which a decimal point should be understood. +(define (stdio:parse-float str) + (let ((n (string-length str))) + (letrec ((prefix + (lambda (i rest) + (if (and (< i (- n 1)) + (char=? #\# (string-ref str i))) + (case (string-ref str (+ i 1)) + ((#\d #\i #\e) (prefix (+ i 2) rest)) + ((#\.) (rest i)) + (else (parse-error))) + (rest i)))) + (sign + (lambda (i rest) + (if (< i n) + (let ((c (string-ref str i))) + (case c + ((#\- #\+) (cons c (rest (+ i 1)))) + (else (cons #\+ (rest i)))))))) + (digits + (lambda (i rest) + (do ((j i (+ j 1))) + ((or (>= j n) + (not (or (char-numeric? (string-ref str j)) + (char=? #\# (string-ref str j))))) + (cons + (if (= i j) "0" (substring str i j)) + (rest j)))))) + (point + (lambda (i rest) + (if (and (< i n) + (char=? #\. (string-ref str i))) + (rest (+ i 1)) + (rest i)))) + (exp + (lambda (i) + (if (< i n) + (case (string-ref str i) + ((#\e #\s #\f #\d #\l #\E #\S #\F #\D #\L) + (let ((s (sign (+ i 1) (lambda (i) (digits i end))))) + (list + (if (char=? #\- (car s)) + (- (string->number (cadr s))) + (string->number (cadr s)))))) + (else (parse-error))) + '(0)))) + (end + (lambda (i) + (if (< i n) (parse-error) '()))) + (parse-error + (lambda () #f))) + (let ((parsed + (prefix 0 + (lambda (i) + (sign i + (lambda (i) + (digits i + (lambda (i) + (point i + (lambda (i) + (digits i exp))))))))))) + (and (list? parsed) + (apply + (lambda (sgn idigs fdigs exp) + (let* ((digs (string-append "0" idigs fdigs)) + (n (string-length digs))) + (let loop ((i 1) + (exp (+ exp (string-length idigs)))) + (if (and (< i n) + (char=? #\0 (string-ref digs i))) + (loop (+ i 1) (- exp 1)) + (list sgn (substring digs (- i 1) n) exp))))) + parsed)))))) -(define (stdio:iprintf out-proc format-string . args) - (define char-count 0) - (define (out c) - (cond ((char? c) (set! char-count (+ 1 char-count))) - (else (set! char-count (+ (string-length c) char-count)))) - (out-proc c) #t) +;; STR is a digit string representing a floating point mantissa, STR must +;; begin with "0", after which a decimal point is understood. +;; The output is a digit string rounded to NDIGS digits after the decimal +;; point implied between chars 0 and 1. +;; If STRIP-0S is not #F then trailing zeros will be stripped from the result. +;; In this case, STRIP-0S should be the minimum number of digits required +;; after the implied decimal point. +(define (stdio:round-string str ndigs strip-0s) + (let* ((n (- (string-length str) 1)) + (res + (cond ((< ndigs 0) "") + ((= n ndigs) str) + ((< n ndigs) + (if strip-0s str + (string-append + str (make-string (- ndigs n) + (if (char-numeric? (string-ref str n)) + #\0 #\#))))) + (else + (let ((res (substring str 0 (+ ndigs 1))) + (dig (lambda (i) + (let ((c (string-ref str i))) + (if (char-numeric? c) + (string->number (string c)) + 0))))) + (let ((ldig (dig (+ 1 ndigs)))) + (if (or (> ldig 5) + (and (= ldig 5) + (let loop ((i (+ 2 ndigs))) + (if (> i n) (odd? (dig ndigs)) + (if (zero? (dig i)) + (loop (+ i 1)) + #t))))) + (let inc! ((i ndigs)) + (let ((d (dig i))) + (if (< d 9) + (string-set! res i + (string-ref + (number->string (+ d 1)) 0)) + (begin + (string-set! res i #\0) + (inc! (- i 1)))))))) + res))))) + (if strip-0s + (let loop ((i (- (string-length res) 1))) + (if (or (<= i strip-0s) + (not (char=? #\0 (string-ref res i)))) + (substring res 0 (+ i 1)) + (loop (- i 1)))) + res))) + + +(define (stdio:iprintf out format-string . args) (cond ((not (equal? "" format-string)) (let ((pos -1) @@ -53,14 +175,14 @@ ((end-of-format?)) ((eqv? #\\ fc);;Emulating C strings may not be a good idea. (must-advance) - (case fc - ((#\n #\N) (out #\newline)) - ((#\t #\T) (out slib:tab)) - ;;((#\r #\R) (out #\return)) - ((#\f #\F) (out slib:form-feed)) - ((#\newline) #f) - (else (out fc))) - (loop args)) + (and (case fc + ((#\n #\N) (out #\newline)) + ((#\t #\T) (out slib:tab)) + ;;((#\r #\R) (out #\return)) + ((#\f #\F) (out slib:form-feed)) + ((#\newline) #t) + (else (out fc))) + (loop args))) ((eqv? #\% fc) (must-advance) (let ((left-adjust #f) ;- @@ -85,45 +207,130 @@ (string->number (string c))))) ((not (char-numeric? fc)) accum) (must-advance))))))) + (define (pad pre . strs) + (let loop ((len (string-length pre)) + (ss strs)) + (cond ((>= len width) (apply string-append pre strs)) + ((null? ss) + (cond (left-adjust + (apply string-append + pre + (append strs + (list (make-string + (- width len) #\space))))) + (leading-0s + (apply string-append + pre + (make-string (- width len) #\0) + strs)) + (else + (apply string-append + (make-string (- width len) #\space) + pre strs)))) + (else + (loop (+ len (string-length (car ss))) (cdr ss)))))) (define integer-convert (lambda (s radix) + (cond ((not (negative? precision)) + (set! leading-0s #f) + (if (and (zero? precision) + (eqv? 0 s)) + (set! s "")))) (set! s (cond ((symbol? s) (symbol->string s)) ((number? s) (number->string s radix)) ((or (not s) (null? s)) "0") + ((string? s) s) (else "1"))) - (cond ((not (negative? precision)) - (set! leading-0s #f))) - (let* ((pre - (cond ((equal? "" s) "") - ((eqv? #\- (string-ref s 0)) - (set! s (substring s 1 (string-length s))) - "-") - (signed "+") - (blank " ") - ((equal? "" s) "") - (alternate-form - (case radix - ((8) "0") - ((16) "0x") - (else ""))) - (else ""))) - (length-so-far (+ (string-length pre) - (string-length s)))) - (cond ((<= width length-so-far) - (string-append pre s)) - (left-adjust - (string-append - pre s - (make-string (- width length-so-far) #\ ))) - (leading-0s - (string-append - pre (make-string (- width length-so-far) #\0) - s)) + (let ((pre (cond ((equal? "" s) "") + ((eqv? #\- (string-ref s 0)) + (set! s (substring s 1 (string-length s))) + "-") + (signed "+") + (blank " ") + (alternate-form + (case radix + ((8) "0") + ((16) "0x") + (else ""))) + (else "")))) + (pad pre + (if (< (string-length s) precision) + (make-string + (- precision (string-length s)) #\0) + "") + s)))) + (define (float-convert num fc) + (define (f digs exp strip-0s) + (let ((digs (stdio:round-string + digs (+ exp precision) (and strip-0s exp)))) + (cond ((>= exp 0) + (let* ((i0 (cond ((zero? exp) 0) + ((char=? #\0 (string-ref digs 0)) 1) + (else 0))) + (i1 (max 1 (+ 1 exp))) + (idigs (substring digs i0 i1)) + (fdigs (substring digs i1 + (string-length digs)))) + (cons idigs + (if (and (string=? fdigs "") + (not alternate-form)) + '() + (list "." fdigs))))) + ((zero? precision) + (list (if alternate-form "0." "0"))) + ((string=? digs "") (list "0")) (else - (string-append - (make-string (- width length-so-far) #\ ) - pre s)))))) - + (list "0." + (make-string (min precision (- -1 exp)) #\0) + digs))))) + (define (e digs exp strip-0s) + (let* ((digs (stdio:round-string + digs (+ 1 precision) (and strip-0s 0))) + (istrt (if (char=? #\0 (string-ref digs 0)) 1 0)) + (fdigs (substring + digs (+ 1 istrt) (string-length digs))) + (exp (if (zero? istrt) exp (- exp 1)))) + (list + (substring digs istrt (+ 1 istrt)) + (if (and (string=? fdigs "") (not alternate-form)) + "" ".") + fdigs + (if (char-upper-case? fc) "E" "e") + (if (negative? exp) "-" "+") + (if (< -10 exp 10) "0" "") + (number->string (abs exp))))) + (cond ((negative? precision) + (set! precision 6)) + ((and (zero? precision) + (char-ci=? fc #\g)) + (set! precision 1))) + (let* ((str + (cond ((number? num) + (number->string (exact->inexact num))) + ((string? num) num) + ((symbol? num) (symbol->string num)) + (else "???"))) + (parsed (stdio:parse-float str))) + (cond (parsed + (apply + (lambda (sgn digs exp) + (apply pad + (if (char=? #\- sgn) "-" + (if signed "+" (if blank " " ""))) + (case fc + ((#\e #\E) (e digs exp #f)) + ((#\f #\F) (f digs exp #f)) + ((#\g #\G) + (let ((strip-0s (not alternate-form))) + (set! alternate-form #f) + (cond ((< -4 exp (+ 1 precision)) + (set! precision (- precision exp)) + (f digs exp strip-0s)) + (else + (set! precision (- precision 1)) + (e digs exp strip-0s)))))))) + parsed)) + (else str)))) (do () ((case fc ((#\-) (set! left-adjust #t) #f) @@ -151,8 +358,7 @@ (case fc ;; only - is allowed between % and c ((#\c #\C) ; C is enhancement - (out (string (car args))) - (loop (cdr args))) + (and (out (string (car args))) (loop (cdr args)))) ;; only - flag, no type-modifiers ((#\s #\S) ; S is enhancement @@ -163,25 +369,28 @@ (cond ((not (or (negative? precision) (>= precision (string-length s)))) (set! s (substring s 0 precision)))) - (out - (cond - ((<= width (string-length s)) s) - (left-adjust - (string-append - s (make-string (- width (string-length s)) #\ ))) - (else - (string-append (make-string (- width (string-length s)) - (if leading-0s #\0 #\ )) s)))) - (loop (cdr args)))) + (and (out (cond + ((<= width (string-length s)) s) + (left-adjust + (string-append + s (make-string (- width (string-length s)) #\ ))) + (else + (string-append + (make-string (- width (string-length s)) + (if leading-0s #\0 #\ )) s)))) + (loop (cdr args))))) ;; SLIB extension - ((#\a #\A) ;#\y #\Y are pretty-print + ((#\a #\A) ;#\a #\A are pretty-print (require 'generic-write) (let ((os "") (pr precision)) (generic-write (car args) (not alternate-form) #f (cond ((and left-adjust (negative? pr)) - out) + (set! pr 0) + (lambda (s) + (set! pr (+ pr (string-length s))) + (out s))) (left-adjust (lambda (s) (define sl (- pr (string-length s))) @@ -209,65 +418,87 @@ (else (set! os (string-append os s)))) (set! pr sl) (positive? sl))))) - (cond (left-adjust + (cond ((and left-adjust (negative? precision)) + (cond + ((> width pr) (out (make-string (- width pr) #\ ))))) + (left-adjust (cond ((> width (- precision pr)) - (out (make-string (- width (- precision pr)) - #\ ))))) + (out (make-string (- width (- precision pr)) #\ ))))) ((not os)) ((<= width (string-length os)) (out os)) - (else - (out (make-string (- width (string-length os)) #\ )) - (out os)))) + (else (and (out (make-string + (- width (string-length os)) #\ )) + (out os))))) (loop (cdr args))) ((#\d #\D #\i #\I #\u #\U) - (out (integer-convert (car args) 10)) - (loop (cdr args))) + (and (out (integer-convert (car args) 10)) (loop (cdr args)))) ((#\o #\O) - (out (integer-convert (car args) 8)) - (loop (cdr args))) + (and (out (integer-convert (car args) 8)) (loop (cdr args)))) ((#\x #\X) - (out ((if (char-upper-case? fc) string-upcase string-downcase) - (integer-convert (car args) 16))) - (loop (cdr args))) - ((#\%) (out #\%) - (loop args)) + (and (out ((if (char-upper-case? fc) + string-upcase string-downcase) + (integer-convert (car args) 16))) + (loop (cdr args)))) + ((#\b #\B) + (and (out (integer-convert (car args) 2)) (loop (cdr args)))) + ((#\%) (and (out #\%) (loop args))) + ((#\f #\F #\e #\E #\g #\G) + (and (out (float-convert (car args) fc)) (loop (cdr args)))) (else (cond ((end-of-format?) (incomplete)) - (else (out #\%) (out fc) (out #\?) - (loop args))))))) - (else (out fc) - (loop args))))))) - char-count) ; return number of characters output. - -(define (stdio:printf format . args) - (apply stdio:iprintf display format args)) + (else (and (out #\%) (out fc) (out #\?) (loop args)))))))) + (else (and (out fc) (loop args))))))))) (define (stdio:fprintf port format . args) - (if (equal? port (current-output-port)) - (apply stdio:iprintf display format args) - (apply stdio:iprintf (lambda (x) (display x port)) format args))) + (let ((cnt 0)) + (apply stdio:iprintf + (lambda (x) + (cond ((string? x) + (set! cnt (+ (string-length x) cnt)) (display x port) #t) + (else (set! cnt (+ 1 cnt)) (display x port) #t))) + format args) + cnt)) -(define (stdio:sprintf s format . args) - (let ((p 0) (end (string-length s))) +(define (stdio:printf format . args) + (apply stdio:fprintf (current-output-port) format args)) + +(define (stdio:sprintf str format . args) + (let* ((cnt 0) + (s (cond ((string? str) str) + ((number? str) (make-string str)) + ((not str) (make-string 100)) + (else (slib:error 'sprintf "first argument not understood" + str)))) + (end (string-length s))) (apply stdio:iprintf (lambda (x) (cond ((string? x) - (do ((i 0 (+ i 1))) - ((>= i (min (string-length x) end))) - (string-set! s p (string-ref x i)) - (set! p (+ p 1)))) - ((>= p end)) - ((char? x) - (string-set! s p x) - (set! p (+ p 1))) - (else - (string-set! s p #\?) - (set! p (+ p 1))))) + (if (or str (>= (- end cnt) (string-length x))) + (do ((lend (min (string-length x) (- end cnt))) + (i 0 (+ i 1))) + ((>= i lend)) + (string-set! s cnt (string-ref x i)) + (set! cnt (+ cnt 1))) + (let () + (set! s (string-append (substring s 0 cnt) x)) + (set! cnt (string-length s)) + (set! end cnt)))) + ((and str (>= cnt end))) + (else (cond ((and (not str) (>= cnt end)) + (set! s (string-append s (make-string 100))) + (set! end (string-length s)))) + (string-set! s cnt (if (char? x) x #\?)) + (set! cnt (+ cnt 1)))) + (not (and str (>= cnt end)))) format args) - p)) + (cond ((string? str) cnt) + ((eqv? end cnt) s) + (else (substring s 0 cnt))))) (define printf stdio:printf) (define fprintf stdio:fprintf) (define sprintf stdio:sprintf) + +;;(do ((i 0 (+ 1 i))) ((> i 50)) (printf "%s\n" (sprintf i "%#-13a:%#13a:%-13.8a:" "123456789" "123456789" "123456789"))) @@ -19,15 +19,6 @@ (define *qp-width* (output-port-width (current-output-port))) -(define qp:qpn - (let ((newline newline) (apply apply)) - (lambda objs (apply qp:qp objs) (newline)))) - -(define qp:qpr - (let ((- -) (apply apply) (length length) (list-ref list-ref)) - (lambda objs (apply qp:qpn objs) - (list-ref objs (- (length objs) 1))))) - (define qp:qp (let ((+ +) (- -) (< <) (= =) (>= >=) (apply apply) (boolean? boolean?) @@ -136,7 +127,7 @@ (lambda objs (cond - ((= 0 *qp-width*) + ((or (not *qp-width*) (= 0 *qp-width*)) (for-each (lambda (x) (write x) (display #\ )) objs) (newline)) (else @@ -144,6 +135,15 @@ (- *qp-width* (qp-obj (car objs) (l-elt-room *qp-width* objs)))))))))) +(define qp:qpn + (let ((newline newline) (apply apply) (qp:qp qp:qp)) + (lambda objs (apply qp:qp objs) (newline)))) + +(define qp:qpr + (let ((- -) (apply apply) (length length) (list-ref list-ref) (qp:qpn qp:qpn)) + (lambda objs (apply qp:qpn objs) + (list-ref objs (- (length objs) 1))))) + (define qp qp:qp) (define qpn qp:qpn) (define qpr qp:qpr) diff --git a/randinex.scm b/randinex.scm index 1c2b702..e6dc48b 100644 --- a/randinex.scm +++ b/randinex.scm @@ -22,28 +22,26 @@ ;;; Fixed sphere and normal functions from: Harald Hanche-Olsen -(define random:float-radix - (+ 1 (exact->inexact random:MASK))) - -;;; This determines how many chunks will be neccessary to completely -;;; fill up an inexact real. -(define (random:size-float l x) - (cond ((= 1.0 (+ 1 x)) l) - ((= 4 l) l) - (else (random:size-float (+ l 1) (/ x random:float-radix))))) -(define random:chunks/float (random:size-float 0 1.0)) - -(define (random:uniform-chunk n state) - (if (= 1 n) - (/ (exact->inexact (random:chunk state)) - random:float-radix) - (/ (+ (random:uniform-chunk (- n 1) state) - (exact->inexact (random:chunk state))) - random:float-radix))) - ;;; Generate an inexact real between 0 and 1. -(define (random:uniform state) - (random:uniform-chunk random:chunks/float state)) +(define random:uniform + (letrec ((random:chunks/float ; how many chunks fill an inexact? + (letrec ((random:size-float + (lambda (l x) + (cond ((= 1.0 (+ 1 x)) l) + ((= 4 l) l) + (else (random:size-float (+ l 1) (/ x 256.0))))))) + (random:size-float 0 1.0))) + + (random:uniform-chunk + (lambda (n state) + (if (= 1 n) + (/ (exact->inexact (random:chunk state)) + 256.0) + (/ (+ (random:uniform-chunk (- n 1) state) + (exact->inexact (random:chunk state))) + 256.0))))) + (lambda (state) + (random:uniform-chunk random:chunks/float state)))) ;;; If x and y are independent standard normal variables, then with ;;; x=r*cos(t), y=r*sin(t), we find that t is uniformly distributed @@ -81,7 +79,7 @@ ;;; For the uniform distribution on the solid sphere, note that in ;;; this distribution the length r of the vector has cumulative -;;; distribution r^n; i.e., u=r^n is uniform [0,1], so r kan be +;;; distribution r^n; i.e., u=r^n is uniform [0,1], so r can be ;;; generated as r=u^(1/n). (define (random:solid-sphere! vect . args) @@ -95,5 +93,3 @@ (define (random:exp . args) (let ((state (if (null? args) *random-state* (car args)))) (- (log (random:uniform state))))) - -(require 'random) @@ -17,85 +17,80 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'byte) (require 'logical) -(define random:tap 24) -(define random:size 55) +(define (make-rng seed) + (define mutex #f) + (define idx 0) + (define idy 0) + (define sta (make-bytes 256)) + ; initialize state + (do ((idx #xff (+ -1 idx))) + ((negative? idx)) + (byte-set! sta idx idx)) -(define (random:size-int l) - (let ((trial (string->number (make-string l #\f) 16))) - (if (and (exact? trial) (>= most-positive-fixnum trial)) - l - (random:size-int (- l 1))))) -(define random:chunk-size (* 4 (random:size-int 8))) + (if (number? seed) + (set! seed (number->string seed))) -(define random:MASK - (string->number (make-string (quotient random:chunk-size 4) #\f) 16)) + ; merge seed into state + (do ((idx 0 (+ 1 idx)) + (kdx 0 (modulo (+ 1 kdx) seed-len)) + (seed-len (bytes-length seed))) + ((>= idx 256) (set! idy 0)) + (let ((swp (byte-ref sta idx))) + (set! idy (logand #xff (+ idy (byte-ref seed kdx) swp))) + (byte-set! sta idx (byte-ref sta idy)) + (byte-set! sta idy swp))) + ; spew + (lambda () + (if mutex (slib:error "random state called reentrantly")) + (set! mutex #t) + (set! idx (logand #xff (+ 1 idx))) + (let ((xtm (byte-ref sta idx))) + (set! idy (logand #xff (+ idy xtm))) + (let ((ytm (byte-ref sta idy))) + (byte-set! sta idy xtm) + (byte-set! sta idx ytm) + (let ((ans (byte-ref sta (logand #xff (+ ytm xtm))))) + (set! mutex #f) + ans))))) (define *random-state* - '#( - "d909ef3e" "fd330ab3" "e33f7843" "76783fbd" "f3675fb3" - "b54ef879" "0be45590" "a6794679" "0bcd56d3" "fabcdef8" - "9cbd3efd" "3fd3efcd" "e064ef27" "dddecc08" "34444292" - "85444454" "4c519210" "c0366273" "54734567" "70abcddc" - "1bbdac53" "616c5a86" "a982efa9" "105996a0" "5f0cccba" - "1ea055e1" "fe2acd8d" "1891c1d4" "e6690270" "6912bccc" - "2678e141" "61222224" "907abcbb" "4ad6829b" "9cdd1404" - "57798841" "5b892496" "871c9cd1" "d1e67bda" "8b0a3233" - "578ef23f" "28274ef6" "823ef5ef" "845678c5" "e67890a5" - "5890abcb" "851fa9ab" "13efa13a" "b12278d6" "daf805ab" - "a0befc36" "0068a7b5" "e024fd90" "a7b690e2" "27f3571a" - 0)) + (make-rng "http://swissnet.ai.mit.edu/~jaffer/SLIB.html")) -(let ((random-strings *random-state*)) - (set! *random-state* (make-vector (+ random:size 1) 0)) - (let ((nibbles (quotient random:chunk-size 4))) - (do ((i 0 (+ i 1))) - ((= i random:size)) - (vector-set! - *random-state* i - (string->number (substring (vector-ref random-strings i) - 0 nibbles) - 16))))) - -;;; random:chunk returns an integer in the range of -;;; 0 to (- (expt 2 random:chunk-size) 1) -(define (random:chunk v) - (let* ((p (vector-ref v random:size)) - (ans (logical:logxor - (vector-ref v (modulo (- p random:tap) random:size)) - (vector-ref v p)))) - (vector-set! v p ans) - (vector-set! v random:size (modulo (- p 1) random:size)) - ans)) +;;; random:chunk returns an integer in the range of 0 to 255. +(define (random:chunk v) (v)) (define (random:random modu . args) (let ((state (if (null? args) *random-state* (car args)))) (if (exact? modu) - (do ((ilen 0 (+ 1 ilen)) - (s random:MASK - (+ random:MASK (* (+ 1 random:MASK) s)))) - ((>= s (- modu 1)) - (let ((slop (modulo (+ s (- 1 modu)) modu))) - (let loop ((n ilen) - (r (random:chunk state))) - (cond ((not (zero? n)) - (loop (+ -1 n) - (+ (* r (+ 1 random:MASK)) - (random:chunk state)))) - ((>= r slop) (modulo r modu)) - (else (loop ilen (random:chunk state)))))))) + (let ((bitlen (integer-length (+ -1 modu)))) + (do ((bln bitlen (+ -8 bln)) + (rbs 0 (+ (ash rbs 8) (random:chunk state)))) + ((<= bln 7) + (modulo + (if (zero? bln) rbs + (+ (ash rbs bln) + (logand (bit-field (random:chunk state) 0 bln)))) + modu)))) (* (random:uniform state) modu)))) ;;;random:uniform is in randinex.scm. It is needed only if inexact is ;;;supported. -(define (random:make-random-state . args) - (let ((state (if (null? args) *random-state* (car args)))) - (list->vector (vector->list state)))) +(define (make-random-state . args) + (let ((seed (if (null? args) + (do ((bts (make-bytes 10)) + (idx 0 (+ 1 idx))) + ((>= idx 10) bts) + (byte-set! bts idx (random:random 256))) + (let () + (require 'object->string) + (object->limited-string (car args) 20))))) + (make-rng seed))) (define random random:random) -(define make-random-state random:make-random-state) (provide 'random) ;to prevent loops (if (provided? 'inexact) (require 'random-inexact)) @@ -216,8 +216,9 @@ base:catalog base:domains rdms:catalog) (define (write-database filename) - (write-base lldb filename) - (set! rdms:filename filename)) + (let ((ans (write-base lldb filename))) + (and ans (set! rdms:filename filename)) + ans)) (define (close-database) (close-base lldb) @@ -489,19 +490,19 @@ (let ((ci (translate-column (cadr args)))) (cond ((<= ci primary-limit) ;primary-key? - (let ((key-extractor - ((base 'make-key-extractor) - primary-limit column-type-list ci))) - (case (car args) - ((get) (lambda keys - (and (present? base-table (list->key keys)) - (list-ref keys (+ -1 ci))))) - ((get*) (lambda mkeys + (case (car args) + ((get) (lambda gkeys + (and (present? base-table (list->key gkeys)) + (list-ref gkeys (+ -1 ci))))) + ((get*) (let ((key-extractor + ((base 'make-key-extractor) + primary-limit column-type-list ci))) + (lambda mkeys (base:map-primary-key base-table (lambda (ckey) (key-extractor ckey)) - (norm-mkeys mkeys)))) - (else #f)))) + (norm-mkeys mkeys))))) + (else #f))) (else (let ((index (- ci (+ 1 primary-limit)))) (case (car args) @@ -66,7 +66,7 @@ ;; Internal accessor functions. No error checking. (rtd-tag (lambda (x) (vect-ref x 0))) - (rtd-name (lambda (rtd) (vect-ref rtd 1))) + (rtd-name (lambda (rtd) (if (vector? rtd) (vect-ref rtd 1) "rtd"))) (rtd-fields (lambda (rtd) (vect-ref rtd 3))) ;; rtd-vfields is padded out to the length of the vector, which is 1 ;; more than the number of fields diff --git a/require.scm b/require.scm index 5b02ff6..ebaf49f 100644 --- a/require.scm +++ b/require.scm @@ -17,7 +17,7 @@ ;promotional, or sales literature without prior written consent in ;each case. -(define *SLIB-VERSION* "2c0") +(define *SLIB-VERSION* "2c3") ;;; Standardize msdos -> ms-dos. (define software-type @@ -41,11 +41,13 @@ ((UNIX COHERENT) '(#\/)) ((VMS) '(#\: #\]))))) (lambda () - (let loop ((i (- (string-length *load-pathname*) 1))) - (cond ((negative? i) "") - ((memv (string-ref *load-pathname* i) *vicinity-suffix*) - (substring *load-pathname* 0 (+ i 1))) - (else (loop (- i 1)))))))) + (if *load-pathname* + (let loop ((i (- (string-length *load-pathname*) 1))) + (cond ((negative? i) "") + ((memv (string-ref *load-pathname* i) *vicinity-suffix*) + (substring *load-pathname* 0 (+ i 1))) + (else (loop (- i 1))))) + (slib:error "Not loading but called" 'program-vicinity))))) (define sub-vicinity (case (software-type) @@ -156,12 +158,13 @@ (define (require:require feature) (or (require:provided? feature) - (let ((path (require:feature->path feature))) + (let ((path (catalog:get feature))) (cond ((and (not path) (string? feature) (file-exists? feature)) (set! path feature))) (cond ((not feature) (set! *catalog* #f)) ((not path) (slib:error ";required feature not supported: " feature)) + ((symbol? path) (require:require path) (require:provide feature)) ((not (pair? path)) ;simple name (slib:load path) (and (not (eq? 'new-catalog feature)) (require:provide feature))) diff --git a/scheme2c.init b/scheme2c.init index 7caf944..0743113 100644 --- a/scheme2c.init +++ b/scheme2c.init @@ -170,8 +170,7 @@ ;;; Return argument (define (identity x) x) -;;; If your implementation provides eval, SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) (define-macro defmacro diff --git a/scheme48.init b/scheme48.init index e65ae8e..6df37b8 100644 --- a/scheme48.init +++ b/scheme48.init @@ -87,8 +87,8 @@ delay ;has delay and force with-file char-ready? ;has + eval ;proposed 2-argument eval values ;proposed multiple values - eval ;slib:eval is single argument eval. dynamic-wind ;proposed dynamic-wind full-continuation ;can return multiple times macro ;R4RS appendix's DEFINE-SYNTAX @@ -155,8 +155,7 @@ ;;; Return argument (define (identity x) x) -;;; If your implementation provides eval, SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval (let ((eval eval) (interaction-environment interaction-environment)) diff --git a/schmooz.scm b/schmooz.scm new file mode 100644 index 0000000..9664ac3 --- /dev/null +++ b/schmooz.scm @@ -0,0 +1,605 @@ +;;; schmooz.scm: Program for extracting texinfo comments from Scheme. +;;; Copyright (C) 1998 Radey Shouman and Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;$Header: /usr/local/cvsroot/slib/schmooz.scm,v 1.7 1998/09/10 20:34:26 radey Exp $ +;;$Name: $ + +;;; REPORT an error or warning +(define report + (lambda args + (display *scheme-source-name*) + (display ": In function `") + (display *procedure*) + (display "': ") + (newline) + + (display *derived-txi-name*) + (display ": ") + (display *output-line*) + (display ": warning: ") + (apply qreport args))) + +(define qreport + (lambda args + (for-each (lambda (x) (write x) (display #\ )) args) + (newline))) + +(require 'common-list-functions) ;some +(require 'string-search) +(require 'fluid-let) +(require 'line-i/o) ;read-line +(require 'filename) +(require 'scanf) +;;(require 'debug) (set! *qp-width* 100) (define qreport qpn) + +;;; This allows us to test without generating files +(define *scheme-source* (current-input-port)) +(define *scheme-source-name* "stdin") +(define *derived-txi* (current-output-port)) +(define *derived-txi-name* "?") + +(define *procedure* #f) +(define *output-line* 0) + +(define CONTLINE -80) + +;;; OUT indents and displays the arguments +(define (out indent . args) + (cond ((>= indent 0) + (newline *derived-txi*) + (set! *output-line* (+ 1 *output-line*)) + (do ((j indent (- j 8))) + ((> 8 j) + (do ((i j (- i 1))) + ((>= 0 i)) + (display #\ *derived-txi*))) + (display #\ *derived-txi*)))) + (for-each (lambda (a) + (cond ((symbol? a) + (display a *derived-txi*)) + ((string? a) + (display a *derived-txi*) + #+f + (cond ((string-index a #\nl) + (set! *output-line* (+ 1 *output-line*)) + (report "newline in string" a)))) + (else + (display a *derived-txi*)))) + args)) + +;; LINE is a string, ISTRT the index in LINE at which to start. +;; Returns a list (next-char-number . list-of-tokens). +;; arguments look like: +;; "(arg1 arg2)" or "{arg1,arg2}" or the whole line is split +;; into whitespace separated tokens. +(define (parse-args line istrt) + (define (tok1 istrt close sep? splice) + (let loop-args ((istrt istrt) + (args '())) + (let loop ((iend istrt)) + (cond ((>= iend (string-length line)) + (if close + (slib:error close "not found in" line) + (cons iend + (reverse + (if (> iend istrt) + (cons (substring line istrt iend) args) + args))))) + ((eqv? close (string-ref line iend)) + (cons (+ iend 1) + (reverse (if (> iend istrt) + (cons (substring line istrt iend) args) + args)))) + ((sep? (string-ref line iend)) + (let ((arg (and (> iend istrt) + (substring line istrt iend)))) + (if (equal? arg splice) + (let ((rest (tok1 (+ iend 1) close sep? splice))) + (cons (car rest) + (append args (cadr rest)))) + (loop-args (+ iend 1) + (if arg + (cons arg args) + args))))) + (else + (loop (+ iend 1))))))) + (let skip ((istrt istrt)) + (cond ((>= istrt (string-length line)) (cons istrt '())) + ((char-whitespace? (string-ref line istrt)) + (skip (+ istrt 1))) + ((eqv? #\{ (string-ref line istrt)) + (tok1 (+ 1 istrt) #\} (lambda (c) (eqv? c #\,)) #f)) + ((eqv? #\( (string-ref line istrt)) + (tok1 (+ 1 istrt) #\) char-whitespace? ".")) + (else + (tok1 istrt #f char-whitespace? #f))))) + + +;; Substitute @ macros in string LINE. +;; Returns a list, the first element is the substituted version +;; of LINE, the rest are lists beginning with '@dfn or '@args +;; and followed by the arguments that were passed to those macros. +;; MACS is an alist of (macro-name . macro-value) pairs. +(define (substitute-macs line macs) + (define (get-word i) + (let loop ((j (+ i 1))) + (cond ((>= j (string-length line)) + (substring line i j)) + ((or (char-alphabetic? (string-ref line j)) + (char-numeric? (string-ref line j))) + (loop (+ j 1))) + (else (substring line i j))))) + (let loop ((istrt 0) + (i 0) + (res '())) + (cond ((>= i (string-length line)) + (list + (apply string-append + (reverse + (cons (substring line istrt (string-length line)) + res))))) + ((char=? #\@ (string-ref line i)) + (let* ((w (get-word i)) + (symw (string->symbol w))) + (cond ((eq? '@cname symw) + (let ((args (parse-args + line (+ i (string-length w))))) + (cond ((and args (= 2 (length args))) + (loop (car args) (car args) + (cons + (string-append + "@code{" (cadr args) "}") + (cons (substring line istrt i) res)))) + (else + (report "@cname wrong number of args" line) + (loop istrt (+ i (string-length w)) res))))) + ((eq? '@dfn symw) + (let* ((args (parse-args + line (+ i (string-length w)))) + (inxt (car args)) + (rest (loop inxt inxt + (cons (substring line istrt inxt) + res)))) + (cons (car rest) + (cons (cons '@dfn (cdr args)) + (cdr rest))))) + ((eq? '@args symw) + (let* ((args (parse-args + line (+ i (string-length w)))) + (inxt (car args)) + (rest (loop inxt inxt res))) + (cons (car rest) + (cons (cons '@args (cdr args)) + (cdr rest))))) + ((assq symw macs) => + (lambda (s) + (loop (+ i (string-length w)) + (+ i (string-length w)) + (cons (cdr s) + (cons (substring line istrt i) res))))) + (else (loop istrt (+ i (string-length w)) res))))) + (else (loop istrt (+ i 1) res))))) + + +(define (sexp-def sexp) + (and (pair? sexp) + (memq (car sexp) '(DEFINE DEFVAR DEFCONST DEFINE-SYNTAX DEFMACRO)) + (car sexp))) + +(define def->var-name cadr) + +(define (def->args sexp) + (define name (cadr sexp)) + (define (body forms) + (if (pair? forms) + (if (null? (cdr forms)) + (form (car forms)) + (body (cdr forms))) + #f)) + (define (form sexp) + (if (pair? sexp) + (case (car sexp) + ((LAMBDA) (cons name (cadr sexp))) + ((BEGIN) (body (cdr sexp))) + ((LET LET* LETREC) + (if (or (null? (cadr sexp)) + (pair? (cadr sexp))) + (body (cddr sexp)) + (body (cdddr sexp)))) ;named LET + (else #f)) + #f)) + (case (car sexp) + ((DEFINE) (if (pair? name) + name + (form (caddr sexp)))) + ((DEFINE-SYNTAX) '()) + ((DEFMACRO) (cons (cadr sexp) (caddr sexp))) + ((DEFVAR DEFCONST) #f) + (else (slib:error 'schmooz "doesn't look like definition" sexp)))) + +;; Generate alist of argument macro definitions. +;; If ARGS is a symbol or string, then the definitions will be used in a +;; `defvar', if ARGS is a (possibly improper) list, they will be used in +;; a `defun'. +(define (scheme-args->macros args) + (define (arg->string a) + (if (string? a) a (symbol->string a))) + (define (arg->macros arg i) + (let ((s (number->string i)) + (m (string-append "@var{" (arg->string arg) "}"))) + (list (cons (string->symbol (string-append "@" s)) m) + (cons (string->symbol (string-append "@arg" s)) m)))) + (let* ((fun? (pair? args)) + (arg0 (if fun? (car args) args)) + (args (if fun? (cdr args) '()))) + (let ((m0 (string-append + (if fun? "@code{" "@var{") (arg->string arg0) "}"))) + (append + (list (cons '@arg0 m0) (cons '@0 m0)) + (let recur ((i 1) + (args args)) + (cond ((null? args) '()) + ((or (symbol? args) ;Rest list + (string? args)) + (arg->macros args i)) + (else + (append (arg->macros (car args) i) + (recur (+ i 1) (cdr args)))))))))) + +;; Extra processing to be done for @dfn +(define (out-cindex arg) + (out 0 "@cindex " arg)) + +;; ARGS looks like the cadr of a function definition: +;; (fun-name arg1 arg2 ...) +(define (schmooz-fun defop args body xdefs) + (define (out-header args op) + (let ((fun (car args)) + (args (cdr args))) + (out 0 #\@ op #\space fun) + (let loop ((args args)) + (cond ((null? args)) + ((symbol? args) + (loop (symbol->string args))) + ((string? args) + (out CONTLINE " " + (let ((n (- (string-length args) 1))) + (if (eqv? #\s (string-ref args n)) + (substring args 0 n) + args)) + " @dots{}")) + ((pair? args) + (out CONTLINE " " + (if (or (eq? '... (car args)) + (equal? "..." (car args))) + "@dots{}" + (car args))) + (loop (cdr args))) + (else (slib:error 'schmooz-fun args)))))) + (let* ((mac-list (scheme-args->macros args)) + (ops (case defop + ((DEFINE-SYNTAX) '("defspec" . "defspecx")) + ((DEFMACRO) '("defmac" . "defmacx")) + (else '("defun" . "defunx"))))) + (out-header args (car ops)) + (let loop ((xdefs xdefs)) + (cond ((pair? xdefs) + (out-header (car xdefs) (cdr ops)) + (loop (cdr xdefs))))) + (for-each (lambda (subl) + (out 0 (car subl)) + (for-each (lambda (l) + (case (car l) + ((@dfn) + (out-cindex (cadr l))) + ((@args) + (out-header + (cons (car args) (cdr l)) + (cdr ops))))) + (cdr subl))) + (map (lambda (bl) + (substitute-macs bl mac-list)) + body)) + (out 0 "@end " (car ops)) + (out 0))) + +(define (schmooz-var defop name body xdefs) + (let* ((mac-list (scheme-args->macros name))) + (out 0 "@defvar " name) + (let loop ((xdefs xdefs)) + (cond ((pair? xdefs) + (out 0 "@defvarx " (car xdefs)) + (loop (cdr xdefs))))) + (for-each (lambda (subl) + (out 0 (car subl)) + (for-each (lambda (l) + (case (car l) + ((@dfn) (out-cindex (cadr l))) + (else + (report "bad macro" l)))) + (cdr subl))) + (map (lambda (bl) + (substitute-macs bl mac-list)) + body)) + (out 0 "@end defvar") + (out 0))) + +;;; SCHMOOZ files. +(define schmooz + (let* ((scheme-file? (filename:match-ci?? "*??scm")) + (txi-file? (filename:match-ci?? "*??txi")) + (texi-file? (let ((tex? (filename:match-ci?? "*??tex")) + (texi? (filename:match-ci?? "*??texi"))) + (lambda (filename) (or (txi-file? filename) + (tex? filename) + (texi? filename)))))) + (define (schmooz-texi-file file) + (call-with-input-file file + (lambda (port) + (do ((pos (find-string-from-port? "@include" port) + (find-string-from-port? "@include" port))) + ((not pos)) + (let ((fname #f)) + (cond ((not (eqv? 1 (fscanf port " %s" fname)))) + ((not (txi-file? fname))) + ((not (file-exists? + (replace-suffix fname "txi" "scm")))) + (else (schmooz + (replace-suffix fname "txi" "scm"))))))))) + (define (schmooz-scm-file file txi-name) + (display "Schmoozing ") (write file) + (display " -> ") (write txi-name) (newline) + (fluid-let ((*scheme-source* (open-file file "r")) + (*scheme-source-name* file) + (*derived-txi* (open-file txi-name "w")) + (*derived-txi-name* txi-name)) + (set! *output-line* 1) + (schmooz-tops schmooz-top) + (close-input-port *scheme-source*) + (close-output-port *derived-txi*))) + (lambda files + (for-each (lambda (file) + (define sl (string-length file)) + (cond ((scheme-file? file) + (schmooz-scm-file + file (replace-suffix file "scm" "txi"))) + ((texi-file? file) (schmooz-texi-file file)))) + files)))) + +;;; SCHMOOZ-TOPS - schmooz top level forms. +(define (schmooz-tops schmooz-top) + (let ((doc-lines '()) + (doc-args #f)) + (define (skip-ws line istrt) + (do ((i istrt (+ i 1))) + ((or (>= i (string-length line)) + (not (memv (string-ref line i) + '(#\space #\tab #\;)))) + (substring line i (string-length line))))) + + (define (tok1 line) + (let loop ((i 0)) + (cond ((>= i (string-length line)) line) + ((or (char-whitespace? (string-ref line i)) + (memv (string-ref line i) '(#\; #\( #\{))) + (substring line 0 i)) + (else (loop (+ i 1)))))) + + (define (read-cmt-line) + (cond ((eqv? #\; (peek-char *scheme-source*)) + (read-char *scheme-source*) + (read-cmt-line)) + (else (read-line *scheme-source*)))) + + (define (read-newline) + (if (char=? #\cr (read-char *scheme-source*)) + (if (char=? #\nl (peek-char *scheme-source*)) + (read-char *scheme-source*) + (report "stranded #\\cr")))) + + (define (lp c) + (cond ((eof-object? c) + (cond ((pair? doc-lines) + (report "No definition found for @body doc lines" + (reverse doc-lines))))) + ((memv c '(#\cr #\nl)) + (read-newline) + (set! *output-line* (+ 1 *output-line*)) + (newline *derived-txi*) + (lp (peek-char *scheme-source*))) + ((char-whitespace? c) + (write-char (read-char *scheme-source*) *derived-txi*) + (lp (peek-char *scheme-source*))) + ((char=? c #\;) + (c-cmt c)) + (else + (sx)))) + + (define (sx) + (let* ((s1 (read *scheme-source*)) + (ss ;Read all forms separated only by single newlines. + (let recur () + (case (peek-char *scheme-source*) + ((#\cr) (read-char *scheme-source*) (recur)) + ((#\nl) (read-char *scheme-source*) + (if (eqv? #\( (peek-char *scheme-source*)) + (cons (read *scheme-source*) (recur)) + '())) + (else '()))))) + (cond ((eof-object? s1)) + (else + (schmooz-top s1 ss (reverse doc-lines) doc-args) + (set! doc-lines '()) + (set! doc-args #f) + (lp (peek-char *scheme-source*)))))) + + (define (out-cmt line) + (let ((subl (substitute-macs line '()))) + (newline *derived-txi*) + (display (car subl) *derived-txi*) + (for-each + (lambda (l) + (case (car l) + ((@dfn) + (out-cindex (cadr l))) + (else + (report "bad macro" line)))) + (cdr subl)))) + + ;;Comments not transcribed to generated Texinfo files. + (define (c-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (read-char *scheme-source*) + (c-cmt (peek-char *scheme-source*))) + ;; Escape to start Texinfo comments + ((eqv? #\@ c) + (let* ((line (read-line *scheme-source*)) + (tok (tok1 line))) + (cond ((or (string=? tok "@body") + (string=? tok "@text")) + (set! doc-lines + (cons (skip-ws line (string-length tok)) + doc-lines)) + (body-cmt (peek-char *scheme-source*))) + ((string=? tok "@args") + (let ((args + (parse-args line (string-length tok)))) + (set! doc-args (cdr args)) + (set! doc-lines + (cons (skip-ws line (car args)) + doc-lines))) + (body-cmt (peek-char *scheme-source*))) + (else + (out-cmt (if (string=? tok "@") + (skip-ws line 1) + line)) + (doc-cmt (peek-char *scheme-source*)))))) + ;; Transcribe the comment line to C source file. + (else + (read-line *scheme-source*) ;(out-c-cmt ) + (lp (peek-char *scheme-source*))))) + + ;;Comments incorporated in generated Texinfo files. + ;;Continue adding lines to DOC-LINES until a non-comment + ;;line is reached (may be a blank line). + (define (body-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (set! doc-lines (cons (read-cmt-line) doc-lines)) + (body-cmt (peek-char *scheme-source*))) + ((memv c '(#\nl #\cr)) + (read-newline) + (lp (peek-char *scheme-source*))) + ;; Allow whitespace before ; in doc comments. + ((char-whitespace? c) + (read-char *scheme-source*) + (body-cmt (peek-char *scheme-source*))) + (else + (lp (peek-char *scheme-source*))))) + + ;;Comments incorporated in generated Texinfo files. + ;;Transcribe comments to current position in Texinfo file + ;;until a non-comment line is reached (may be a blank line). + (define (doc-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (out-cmt (read-cmt-line)) + ;;(out-c-cmt (car ls)) + (doc-cmt (peek-char *scheme-source*))) + ((memv c '(#\nl #\cr)) + (read-newline) + (newline *derived-txi*) + (lp (peek-char *scheme-source*))) + ;; Allow whitespace before ; in doc comments. + ((char-whitespace? c) + (read-char *scheme-source*) + (doc-cmt (peek-char *scheme-source*))) + (else + (newline *derived-txi*) + (lp (peek-char *scheme-source*))))) + (lp (peek-char *scheme-source*)))) + +(define (schmooz-top-doc-begin def1 defs doc proc-args) + (let ((op1 (sexp-def def1))) + (cond + ((not op1) + (or (null? doc) + (report "SCHMOOZ: no definition found for Texinfo documentation" + doc (car defs)))) + (else + (let* ((args (def->args def1)) + (args (if proc-args + (cons (if args (car args) (def->var-name def1)) + proc-args) + args))) + (let loop ((ss defs) + (smatch (list (or args (def->var-name def1))))) + (if (null? ss) + (let ((smatch (reverse smatch))) + ((if args schmooz-fun schmooz-var) + op1 (car smatch) doc (cdr smatch))) + (if (eq? op1 (sexp-def (car ss))) + (let ((a (def->args (car ss)))) + (loop (cdr ss) + (if args + (if a + (cons a smatch) + smatch) + (if a + smatch + (cons (def->var-name (car ss)) + smatch))))))))))))) + +;;; SCHMOOZ-TOP - schmooz top level form sexp. +(define (schmooz-top sexp1 sexps doc proc-args) + (cond ((not (pair? sexp1))) + ((pair? sexps) + (schmooz-top-doc-begin sexp1 sexps doc proc-args) + (set! doc '())) + (else + (case (car sexp1) + ((LOAD REQUIRE) ;If you redefine load, you lose + #f) + ((BEGIN) + (schmooz-top (cadr sexp1) '() doc proc-args) + (set! doc '()) + (for-each (lambda (s) + (schmooz-top s '() doc #f)) + (cddr sexp1))) + ((DEFVAR DEFINE DEFCONST DEFINE-SYNTAX DEFMACRO) + (let* ((args (def->args sexp1)) + (args (if proc-args + (cons (if args (car args) (cadr sexp1)) + proc-args) + args))) + (cond (args + (set! *procedure* (car args)) + (cond ((pair? doc) + (schmooz-fun (car sexp1) args doc '()) + (set! doc '())))) + (else + (cond ((pair? doc) + (schmooz-var (car sexp1) (cadr sexp1) doc '()) + (set! doc '())))))))))) + (or (null? doc) + (report + "SCHMOOZ: no definition found for Texinfo documentation" + doc sexp)) + (set! *procedure* #f)) @@ -72,7 +72,7 @@ char-ready? macro ;has R4RS high level macros ; defmacro ;has Common Lisp DEFMACRO - eval ;SLIB:EVAL is single argument eval + eval ;proposed 2-arugment eval ; record ;has user defined data structures values ;proposed multiple values dynamic-wind ;proposed dynamic-wind @@ -134,10 +134,7 @@ ;;; 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) - +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. ; [s48 has two argument eval] (define (slib:eval form) @@ -10,6 +10,11 @@ @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 @@ -21,7 +26,7 @@ This file documents SLIB, the portable Scheme library. Copyright (C) 1993 Todd R. Eigenschink@* -Copyright (C) 1993, 1994, 1995, 1996, 1997 Aubrey Jaffer +Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998 Aubrey Jaffer Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice @@ -48,13 +53,13 @@ by the author. @titlepage @title SLIB @subtitle The Portable Scheme Library -@subtitle Version 2c0 +@subtitle Version 2c3 @author by Aubrey Jaffer @page @vskip 0pt plus 1filll Copyright @copyright{} 1993 Todd R. Eigenschink@* -Copyright @copyright{} 1993, 1994, 1995, 1996, 1997 Aubrey Jaffer +Copyright @copyright{} 1993, 1994, 1995, 1996, 1997, 1998 Aubrey Jaffer Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice @@ -89,7 +94,7 @@ specific to a site, implementation, user, or directory. @quotation Aubrey Jaffer <jaffer@@ai.mit.edu>@* @i{Hyperactive Software} -- The Maniac Inside!@* -http://www-swiss.ai.mit.edu/~jaffer/SLIB.html +@url{http://swissnet.ai.mit.edu/~jaffer/SLIB.html} @end quotation @end ifinfo @@ -125,13 +130,7 @@ specific to a site, implementation, user, or directory. @quotation Aubrey Jaffer <jaffer@@ai.mit.edu>@* @i{Hyperactive Software} -- The Maniac Inside!@* -@ifset html -<A HREF="http://www-swiss.ai.mit.edu/~jaffer/SLIB.html"> -@end ifset -http://www-swiss.ai.mit.edu/~jaffer/SLIB.html -@ifset html -</A> -@end ifset +@url{http://swissnet.ai.mit.edu/~jaffer/SLIB.html} @end quotation @end iftex @@ -316,12 +315,12 @@ 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-*- +;;; "usercat": SLIB catalog additions for SIMSYNCH. -*-scheme-*- ( - (simsynch . "../synch/simsynch.scm") - (run . "../synch/run.scm") - (schlep . "schlep.scm") + (simsynch . "../synch/simsynch.scm") + (run . "../synch/run.scm") + (schlep . "schlep.scm") ) @end example @@ -492,9 +491,9 @@ 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. +@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 @@ -530,8 +529,8 @@ these procedures are file system dependent. @noindent These procedures are provided by all implementations. -@defun make-vicinity filename -Returns the vicinity of @var{filename} for use by @code{in-vicinity}. +@defun make-vicinity path +Returns the vicinity of @var{path} for use by @code{in-vicinity}. @end defun @defun program-vicinity @@ -631,7 +630,7 @@ Displays the versions of SLIB and the underlying Scheme implementation and the name of the operating system. An unspecified value is returned. @example -(slib:report-version) @result{} slib "2c0" on scm "5b1" on unix +(slib:report-version) @result{} slib "2c3" on scm "5b1" on unix @end example @end defun @@ -649,7 +648,7 @@ Writes the report to file @file{filename}. @example (slib:report) @result{} -slib "2c0" on scm "5b1" on unix +slib "2c3" on scm "5b1" on unix (implementation-vicinity) is "/home/jaffer/scm/" (library-vicinity) is "/home/jaffer/slib/" (scheme-file-suffix) is ".scm" @@ -802,7 +801,8 @@ If an implementation does not support compiled code then @deffn Procedure slib:eval obj @code{eval} returns the value of @var{obj} evaluated in the current top -level environment.@refill +level environment. @ref{Eval} provides a more general evaluation +facility. @end deffn @deffn Procedure slib:eval-load filename eval @@ -1916,7 +1916,7 @@ reasonable). See the L&FP paper for some suggestions.@refill @deffn Syntax define-operation @code{(}opname self arg @dots{}@code{)} @var{default-body} Defines a default behavior for data objects which don't handle the -operation @var{opname}. The default default behavior (for an empty +operation @var{opname}. The default behavior (for an empty @var{default-body}) is to generate an error.@refill @end deffn @@ -2134,10 +2134,12 @@ value is unspecified. * Precedence Parsing:: * Format:: Common-Lisp Format * Standard Formatted I/O:: Posix printf and scanf -* Program Arguments:: Commands and Options. +* Programs and Arguments:: +* HTML HTTP and CGI:: Generate pages and serve WWW sites * Printing Scheme:: Nicely * Time and Date:: * Vector Graphics:: +* Schmooz:: Documentation markup for Scheme programs @end menu @@ -2535,8 +2537,8 @@ when @var{tk} is parsed: 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. +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 @@ -2606,7 +2608,7 @@ is parsed: The rules @var{rule1} @dots{} augment and, in case of conflict, override rules currently in effect. @item -Characters are read untile and end-of-file or a sequence of characters +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 @@ -2678,440 +2680,9 @@ The ruleset in effect before @var{tk} was parsed is restored; @code{(require 'format)} @ftindex format -@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 +@include fmtdoc.txi -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 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{~}<newline> -Continuation Line. -@table @asis -@item @code{~:}<newline> -newline is ignored, white space left. -@item @code{~@@}<newline> -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 - - -@node Standard Formatted I/O, Program Arguments, Format, Textual Conversion Packages +@node Standard Formatted I/O, Programs and Arguments, Format, Textual Conversion Packages @section Standard Formatted I/O @menu @@ -3147,6 +2718,8 @@ Defined to be @code{(current-error-port)}. @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 @@ -3157,10 +2730,11 @@ returns the number of characters output. @code{string-set!}s locations of the non-constant string argument @var{str} to the output characters. -@quotation -@emph{Note:} sprintf should be changed to a macro so a @code{substring} -expression could be used for the @var{str} argument. -@end quotation +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 @@ -3300,7 +2874,6 @@ digits @samp{0123456789ABCDEF}. @end table @subsubsection Inexact Conversions -@emph{Note:} Inexact conversions are not supported yet. @table @asis @item @samp{f} @@ -3313,9 +2886,10 @@ between mantissa and exponont. @item @samp{g}, @samp{G} Print a floating-point number in either normal or exponential notation, -whichever is more appropriate for its magnitude. @samp{%g} prints -@samp{e} between mantissa and exponont. @samp{%G} prints @samp{E} -between mantissa and exponont. +whichever is more appropriate for its magnitude. Unless an @samp{#} flag +has been supplied trailing zeros after a decimal point will be stripped +off. @samp{%g} prints @samp{e} between mantissa and exponont. +@samp{%G} prints @samp{E} between mantissa and exponent. @end table @subsubsection Other Conversions @@ -3528,17 +3102,19 @@ left unread in the input stream. @end defmac -@node Program Arguments, Printing Scheme, Standard Formatted I/O, Textual Conversion Packages -@section Program Arguments +@node Programs and Arguments, HTML HTTP and CGI, 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, Program Arguments, Program Arguments +@node Getopt, Command Line, Programs and Arguments, Programs and Arguments @subsection Getopt @code{(require 'getopt)} @@ -3614,15 +3190,16 @@ 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{#\:}. +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{#\:}. +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. +Otherwise, @code{getopt} returns @code{#f} when all command line options +have been parsed. Example: @lisp @@ -3693,7 +3270,7 @@ errors. @end example @end defun -@node Command Line, Parameter lists, Getopt, Program Arguments +@node Command Line, Parameter lists, Getopt, Programs and Arguments @subsection Command Line @code{(require 'read-command)} @@ -3773,7 +3350,7 @@ can begin an object or comment, then an end of file object is returned. -@node Parameter lists, Batch, Command Line, Program Arguments +@node Parameter lists, Getopt Parameter lists, Command Line, Programs and Arguments @subsection Parameter lists @code{(require 'parameters)} @@ -3873,6 +3450,12 @@ 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 Returns @var{argv} converted to a parameter-list. @var{optnames} are the parameter-names. @var{aliases} is a list of lists of strings and @@ -3936,8 +3519,56 @@ Usage: cmd [OPTION ARGUMENT ...] ... 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 true 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 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, , Parameter lists, Program Arguments +@node Batch, , Filenames, Programs and Arguments @subsection Batch @code{(require 'batch)} @@ -4081,18 +3712,6 @@ can be used to derive a filename moved locally from elsewhere. @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 - @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 @@ -4129,6 +3748,8 @@ Here is an example of the use of most of batch's procedures: @ftindex parameters (require 'batch) @ftindex batch +(require 'glob) +@ftindex glob (define batch (create-database #f 'alist-table)) (batch:initialize! batch) @@ -4199,7 +3820,13 @@ hello world @end example -@node Printing Scheme, Time and Date, Program Arguments, Textual Conversion Packages +@node HTML HTTP and CGI, Printing Scheme, Programs and Arguments, Textual Conversion Packages +@section HTML Forms + +@include htmlform.txi + + +@node Printing Scheme, Time and Date, HTML HTTP and CGI, Textual Conversion Packages @section Printing Scheme @menu @@ -4264,11 +3891,7 @@ where @code{(require 'object->string)} @ftindex object->string -@defun object->string obj -Returns the textual representation of @var{obj} as a string. -@end defun - - +@include obj2str.txi @node Pretty-Print, , Object-To-String, Printing Scheme @@ -4484,7 +4107,7 @@ match the arguments to @code{encode-universal-time}. @end defun -@node Vector Graphics, , Time and Date, Textual Conversion Packages +@node Vector Graphics, Schmooz, Time and Date, Textual Conversion Packages @section Vector Graphics @menu @@ -4560,6 +4183,113 @@ be mixed with regular text and ANSI or other terminal control sequences. @deffn Procedure tek41:encode-int number @end deffn +@node Schmooz, , Vector Graphics, Textual Conversion Packages +@section Schmooz + +@cindex schmooz +@dfn{Schmooz} is a simple, lightweight markup language for interspersing +Texinfo documentation with Scheme source code. Schmooz does not create +the top level Texinfo file; it creates @samp{txi} files which can be +imported into the documentation using the Texinfo command +@samp{@@include}. + +@ftindex schmooz +@code{(require 'schmooz)} defines the function @code{schmooz}, which is +used to process files. Files containing schmooz documentation should +not contain @code{(require 'schmooz)}. + +@deffn Procedure schmooz filename@r{scm} @dots{} +@var{Filename}scm should be a string ending with @samp{scm} naming an +existing file containing Scheme source code. @code{schmooz} extracts +top-level comments containing schmooz commands from @var{filename}scm +and writes the converted Texinfo source to a file named +@var{filename}txi. + +@deffnx Procedure schmooz filename@r{texi} @dots{} +@deffnx Procedure schmooz filename@r{tex} @dots{} +@deffnx Procedure schmooz filename@r{txi} @dots{} +@var{Filename} should be a string naming an existing file containing +Texinfo source code. For every occurrence of the string @samp{@@include +@var{filename}txi} within that file, @code{schmooz} calls itself with +the argument @samp{@var{filename}scm}. +@end deffn + +Schmooz comments are distinguished (from non-schmooz comments) by their +first line, which must start with an at-sign (@@) preceded by one or +more semicolons (@t{;}). A schmooz comment ends at the first subsequent +line which does @emph{not} start with a semicolon. Currently schmooz +comments are recognized only at top level. + +Schmooz comments are copied to the Texinfo output file with the leading +contiguous semicolons removed. Certain character sequences starting +with at-sign are treated specially. Others are copied unchanged. + +A schmooz comment starting with @samp{@@body} must be followed by a +Scheme definition. All comments between the @samp{@@body} line and +the definition will be included in a Texinfo definition, either +a @samp{@@defun} or a @samp{@@defvar}, depending on whether a procedure +or a variable is being defined. + +Within the text of that schmooz comment, at-sign +followed by @samp{0} will be replaced by @code{@@code@{procedure-name@}} +if the following definition is of a procedure; or +@code{@@var@{variable@}} if defining a variable. + +An at-sign followed by a non-zero digit will expand to the variable +citation of that numbered argument: @samp{@@var@{argument-name@}}. + +If more than one definition follows a @samp{@@body} comment line +without an intervening blank or comment line, then those definitions +will be included in the same Texinfo definition using @samp{@@defvarx} +or @samp{@@defunx}, depending on whether the first definition is of +a variable or of a procedure. + +Schmooz can figure out whether a definition is of a procedure if +it is of the form: + +@samp{(define (<identifier> <arg> ...) <expression>)} + +@noindent +or if the left hand side of the definition is some form ending in +a lambda expression. Obviously, it can be fooled. In order to +force recognition of a procedure definition, start the documentation +with @samp{@@args} instead of @samp{@@body}. @samp{@@args} should +be followed by the argument list of the function being defined, +which may be enclosed in parentheses and delimited by whitespace, +(as in Scheme), enclosed in braces and separated by commas, (as +in Texinfo), or consist of the remainder of the line, separated +by whitespace. + +For example: + +@example +;;@@args arg1 args ... +;;@@0 takes argument @@1 and any number of @@2 +(define myfun (some-function-returning-magic)) +@end example + +Will result in: + +@example +@@defun myfun arg1 args @@dots@{@} + +@@code@{myfun@} takes argument @@var@{arg1@} and any number of @@var@{args@} +@@end defun +@end example + +@samp{@@args} may also be useful for indicating optional arguments +by name. If @samp{@@args} occurs inside a schmooz comment section, +rather than at the beginning, then it will generate a @samp{@@defunx} +line with the arguments supplied. + + +If the first at-sign in a schmooz comment is immediately followed by +whitespace, then the comment will be expanded to whatever follows that +whitespace. If the at-sign is followed by a non-whitespace character +then the at-sign will be included as the first character of the expansion. +This feature is intended to make it easy to include Texinfo directives +in schmooz comments. + @node Mathematical Packages, Database Packages, Textual Conversion Packages, Top @chapter Mathematical Packages @@ -4588,7 +4318,10 @@ The bit-twiddling functions are made available through the use of the @code{logical} package. @code{logical} is loaded by inserting @code{(require 'logical)} before the code that uses these @ftindex logical -functions.@refill +functions. These functions behave as though operating on integers +in two's-complement representation.@refill + +@subheading Bitwise Operations @defun logand n1 n1 Returns the integer which is the bit-wise AND of the two integer @@ -4635,6 +4368,13 @@ Example: @end lisp @end defun +@defun bitwise-if mask n0 n1 +Returns an integer composed of some bits from integer @var{n0} and some +from integer @var{n1}. A bit of the result is taken from @var{n0} if the +corresponding bit of integer @var{mask} is 1 and from @var{n1} if that bit +of @var{mask} is 0. +@end defun + @defun logtest j k @example (logtest j k) @equiv{} (not (zero? (logand j k))) @@ -4644,6 +4384,26 @@ Example: @end example @end defun +@defun logcount n +Returns the number of bits in integer @var{n}. If integer is positive, +the 1-bits in its binary representation are counted. If negative, the +0-bits in its two's-complement binary representation are counted. If 0, +0 is returned. + +Example: +@lisp +(logcount #b10101010) + @result{} 4 +(logcount 0) + @result{} 0 +(logcount -2) + @result{} 1 +@end lisp +@end defun + + +@subheading Bit Within Word + @defun logbit? index j @example (logbit? index j) @equiv{} (logtest (integer-expt 2 index) j) @@ -4656,6 +4416,53 @@ Example: @end example @end defun +@defun copy-bit index from bit +Returns an integer the same as @var{from} except in the @var{index}th bit, +which is 1 if @var{bit} is @code{#t} and 0 if @var{bit} is @code{#f}. + +Example: +@example +(number->string (copy-bit 0 0 #t) 2) @result{} "1" +(number->string (copy-bit 2 0 #t) 2) @result{} "100" +(number->string (copy-bit 2 #b1111 #f) 2) @result{} "1011" +@end example +@end defun + +@subheading Fields of Bits + +@defun bit-field n start end +@findex bit-extract +Returns the integer composed of the @var{start} (inclusive) through +@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes +the 0-th bit in the result. + +This function was called @code{bit-extract} in previous versions of SLIB. +@refill + +Example: +@lisp +(number->string (bit-field #b1101101010 0 4) 2) + @result{} "1010" +(number->string (bit-field #b1101101010 4 9) 2) + @result{} "10110" +@end lisp +@end defun + +@defun copy-bit-field to start end from +Returns an integer the same as @var{to} except possibly in the +@var{start} (inclusive) through @var{end} (exclusive) bits, which are +the same as those of @var{from}. The 0-th bit of @var{from} becomes the +@var{start}th bit of the result.@refill + +Example: +@example +(number->string (copy-bit-field #b1101101010 0 4 0) 2) + @result{} "1101100000" +(number->string (copy-bit-field #b1101101010 0 4 -1) 2) + @result{} "1101101111" +@end example +@end defun + @defun ash int count Returns an integer equivalent to @code{(inexact->exact (floor (* @var{int} (expt 2 @var{count}))))}.@refill @@ -4669,23 +4476,6 @@ Example: @end lisp @end defun -@defun logcount n -Returns the number of bits in integer @var{n}. If integer is positive, -the 1-bits in its binary representation are counted. If negative, the -0-bits in its two's-complement binary representation are counted. If 0, -0 is returned. - -Example: -@lisp -(logcount #b10101010) - @result{} 4 -(logcount 0) - @result{} 0 -(logcount -2) - @result{} 1 -@end lisp -@end defun - @defun integer-length n Returns the number of bits neccessary to represent @var{n}. @@ -4712,21 +4502,6 @@ Example: @end lisp @end defun -@defun bit-extract n start end -Returns the integer composed of the @var{start} (inclusive) through -@var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes -the 0-th bit in the result.@refill - -Example: -@lisp -(number->string (bit-extract #b1101101010 0 4) 2) - @result{} "1010" -(number->string (bit-extract #b1101101010 4 9) 2) - @result{} "10110" -@end lisp -@end defun - - @node Modular Arithmetic, Prime Testing and Generation, Bit-Twiddling, Mathematical Packages @section Modular Arithmetic @@ -4992,6 +4767,22 @@ done to test a number for primality. @code{(require 'random)} @ftindex random +@cindex RNG +@cindex PRNG +A pseudo-random number generator is only as good as the tests it passes. +George Marsaglia of Florida State University developed a battery of +tests named @dfn{DIEHARD} (@url{http://stat.fsu.edu/~geo/diehard.html}). +@file{diehard.c} has a bug which the patch +@url{ftp://swissnet.ai.mit.edu/pub/users/jaffer/diehard.c.pat} corrects. + +SLIB's new PRNG generates 8 bits at a time. With the degenerate seed +@samp{0}, the numbers generated pass DIEHARD; but when bits are combined +from sequential bytes, tests fail. With the seed +@samp{http://swissnet.ai.mit.edu/~jaffer/SLIB.html}, all of those tests +pass. + +It would be better if there were no bad seeds. For now, use seeds of at +least 30 bytes. @deffn Procedure random n @deffnx Procedure random n state @@ -5022,7 +4813,7 @@ variable @code{*random-state*} and as a second argument to returned. Otherwise a copy of @code{*random-state*} is returned.@refill @end deffn -If inexact numbers are support by the Scheme implementation, +If inexact numbers are supported by the Scheme implementation, @file{randinex.scm} will be loaded as well. @file{randinex.scm} contains procedures for generating inexact distributions.@refill @@ -5808,6 +5599,8 @@ from any @ref{Base Table} implementation. * Catalog Representation:: * Unresolved Issues:: * Database Utilities:: 'database-utilities +* Database Reports:: +* Database Browser:: 'database-browse @end menu @node Motivations, Creating and Opening Relational Databases, Relational Database, Relational Database @@ -5837,7 +5630,7 @@ intermediate files with a text editor to using the interactive program in order to do operations (such as global changes) not forseen by the program's author. -In order to address this need, the concientous software engineer may +In order to address this need, the conscientious software engineer may even provide a scripting language to allow users to make repetitive database changes. Users will grumble that they need to read a large manual and learn yet another programming language (even if it @@ -6411,7 +6204,7 @@ part of transactions also non-reentrant? If so, perhaps suspending transaction capture for the duration of locks would solve this problem. @end table -@node Database Utilities, , Unresolved Issues, Relational Database +@node Database Utilities, Database Reports, Unresolved Issues, Relational Database @subsection Database Utilities @code{(require 'database-utilities)} @@ -6654,9 +6447,8 @@ arguments from a @code{getopt} style argument list (@pxref{Getopt}). (define (cmd . opts) (fluid-let ((*optind* 1)) (printf "%-34s @result{} " - (call-with-output-string (lambda (pt) (write (cons 'cmd opts) pt))) - ;;(apply string-append (map (lambda (x) (string-append x " ")) opts)) - ) + (call-with-output-string + (lambda (pt) (write (cons 'cmd opts) pt)))) (set! opts (cons "cmd" opts)) (force-output) (dbutil:serve-command-line @@ -6788,6 +6580,85 @@ key field table, a foriegn-key domain will be created for it. @end deffn +@noindent +The following example shows a new database with the name of +@file{foo.db} being created with tables describing processor families +and processor/os/compiler combinations. + +@noindent +The database command @code{define-tables} is defined to call +@code{define-tables} with its arguments. The database is also +configured to print @samp{Welcome} when the database is opened. The +database is then closed and reopened. + +@example +(require 'database-utilities) +@ftindex database-utilities +(define my-rdb (create-database "foo.db" 'alist-table)) + +(define-tables my-rdb + '(*commands* + ((name symbol)) + ((parameters parameter-list) + (procedure expression) + (documentation string)) + ((define-tables + no-parameters + no-parameter-names + (lambda (rdb) (lambda specs (apply define-tables rdb specs))) + "Create or Augment tables from list of specs") + (*initialize* + no-parameters + no-parameter-names + (lambda (rdb) (display "Welcome") (newline) rdb) + "Print Welcome")))) + +((my-rdb 'define-tables) + '(processor-family + ((family atom)) + ((also-ran processor-family)) + ((m68000 #f) + (m68030 m68000) + (i386 8086) + (8086 #f) + (powerpc #f))) + + '(platform + ((name symbol)) + ((processor processor-family) + (os symbol) + (compiler symbol)) + ((aix powerpc aix -) + (amiga-dice-c m68000 amiga dice-c) + (amiga-aztec m68000 amiga aztec) + (amiga-sas/c-5.10 m68000 amiga sas/c) + (atari-st-gcc m68000 atari gcc) + (atari-st-turbo-c m68000 atari turbo-c) + (borland-c-3.1 8086 ms-dos borland-c) + (djgpp i386 ms-dos gcc) + (linux i386 linux gcc) + (microsoft-c 8086 ms-dos microsoft-c) + (os/2-emx i386 os/2 gcc) + (turbo-c-2 8086 ms-dos turbo-c) + (watcom-9.0 i386 ms-dos watcom)))) + +((my-rdb 'close-database)) + +(set! my-rdb (open-database "foo.db" 'alist-table)) +@print{} +Welcome +@end example + +@node Database Reports, Database Browser, Database Utilities, Relational Database +@subsection Database Reports + +@noindent +Code for generating database reports is in @file{report.scm}. After +writing it using @code{format}, I discovered that Common-Lisp +@code{format} is not useable for this application because there is no +mechanismm for truncating fields. @file{report.scm} needs to be +rewritten using @code{printf}. + @deffn Procedure create-report rdb destination report-name table @deffnx Procedure create-report rdb destination report-name The symbol @var{report-name} must be primary key in the table named @@ -6859,75 +6730,43 @@ This entire process repeats until all the rows are output. @end itemize @end deffn -@noindent -The following example shows a new database with the name of -@file{foo.db} being created with tables describing processor families -and processor/os/compiler combinations. -@noindent -The database command @code{define-tables} is defined to call -@code{define-tables} with its arguments. The database is also -configured to print @samp{Welcome} when the database is opened. The -database is then closed and reopened. +@node Database Browser, , Database Reports, Relational Database +@subsection Database Browser -@example -(require 'database-utilities) -@ftindex database-utilities -(define my-rdb (create-database "foo.db" 'alist-table)) +(require 'database-browse) -(define-tables my-rdb - '(*commands* - ((name symbol)) - ((parameters parameter-list) - (procedure expression) - (documentation string)) - ((define-tables - no-parameters - no-parameter-names - (lambda (rdb) (lambda specs (apply define-tables rdb specs))) - "Create or Augment tables from list of specs") - (*initialize* - no-parameters - no-parameter-names - (lambda (rdb) (display "Welcome") (newline) rdb) - "Print Welcome")))) +@deffn Procedure browse database -((my-rdb 'define-tables) - '(processor-family - ((family atom)) - ((also-ran processor-family)) - ((m68000 #f) - (m68030 m68000) - (i386 8086) - (8086 #f) - (powerpc #f))) +Prints the names of all the tables in @var{database} and sets browse's +default to @var{database}. - '(platform - ((name symbol)) - ((processor processor-family) - (os symbol) - (compiler symbol)) - ((aix powerpc aix -) - (amiga-dice-c m68000 amiga dice-c) - (amiga-aztec m68000 amiga aztec) - (amiga-sas/c-5.10 m68000 amiga sas/c) - (atari-st-gcc m68000 atari gcc) - (atari-st-turbo-c m68000 atari turbo-c) - (borland-c-3.1 8086 ms-dos borland-c) - (djgpp i386 ms-dos gcc) - (linux i386 linux gcc) - (microsoft-c 8086 ms-dos microsoft-c) - (os/2-emx i386 os/2 gcc) - (turbo-c-2 8086 ms-dos turbo-c) - (watcom-9.0 i386 ms-dos watcom)))) +@deffnx Procedure browse -((my-rdb 'close-database)) +Prints the names of all the tables in the default database. -(set! my-rdb (open-database "foo.db" 'alist-table)) -@print{} -Welcome -@end example +@deffnx Procedure browse table-name + +For each record of the table named by the symbol @var{table-name}, +prints a line composed of all the field values. + +@deffnx Procedure browse pathname +Opens the database named by the string @var{pathname}, prints the names +of all its tables, and sets browse's default to the database. + +@deffnx Procedure browse database table-name + +Sets browse's default to @var{database} and prints the records of the +table named by the symbol @var{table-name}. + +@deffnx Procedure browse pathname table-name + +Opens the database named by the string @var{pathname} and sets browse's +default to it; @code{browse} prints the records of the table named by +the symbol @var{table-name}. + +@end deffn @node Weight-Balanced Trees, , Relational Database, Database Packages @section Weight-Balanced Trees @@ -7003,14 +6842,13 @@ association is a member of the set. Typically a value such as Many operations can be viewed as computing a result that, depending on whether the tree arguments are thought of as sets or maps, is known by -two different names. -An example is @code{wt-tree/member?}, which, when -regarding the tree argument as a set, computes the set membership operation, but, -when regarding the tree as a discrete map, @code{wt-tree/member?} is the -predicate testing if the map is defined at an element in its domain. -Most names in this package have been chosen based on interpreting the -trees as sets, hence the name @code{wt-tree/member?} rather than -@code{wt-tree/defined-at?}. +two different names. An example is @code{wt-tree/member?}, which, when +regarding the tree argument as a set, computes the set membership +operation, but, when regarding the tree as a discrete map, +@code{wt-tree/member?} is the predicate testing if the map is defined at +an element in its domain. Most names in this package have been chosen +based on interpreting the trees as sets, hence the name +@code{wt-tree/member?} rather than @code{wt-tree/defined-at?}. @cindex run-time-loadable option @@ -7041,13 +6879,13 @@ Binary trees require there to be a total order on the keys used to arrange the elements in the tree. Weight balanced trees are organized by @emph{types}, where the type is an object encapsulating the ordering relation. Creating a tree is a two-stage process. First a tree type -must be created from the predicate which gives the ordering. The tree type -is then used for making trees, either empty or singleton trees or trees -from other aggregate structures like association lists. Once created, a -tree `knows' its type and the type is used to test compatibility between -trees in operations taking two trees. Usually a small number of tree -types are created at the beginning of a program and used many times -throughout the program's execution. +must be created from the predicate which gives the ordering. The tree +type is then used for making trees, either empty or singleton trees or +trees from other aggregate structures like association lists. Once +created, a tree `knows' its type and the type is used to test +compatibility between trees in operations taking two trees. Usually a +small number of tree types are created at the beginning of a program and +used many times throughout the program's execution. @deffn {procedure+} make-wt-tree-type key<? This procedure creates and returns a new tree type based on the ordering @@ -7068,11 +6906,10 @@ Two key values are assumed to be equal if neither is less than the other by @var{key<?}. Each call to @code{make-wt-tree-type} returns a distinct value, and -trees are only compatible if their tree types are @code{eq?}. -A consequence is -that trees that are intended to be used in binary tree operations must all be -created with a tree type originating from the same call to -@code{make-wt-tree-type}. +trees are only compatible if their tree types are @code{eq?}. A +consequence is that trees that are intended to be used in binary tree +operations must all be created with a tree type originating from the +same call to @code{make-wt-tree-type}. @end deffn @defvr {variable+} number-wt-type @@ -7364,10 +7201,10 @@ sorted sequence under the tree's ordering relation on the keys. @code{wt-tree/index} returns the @var{index}th key, @code{wt-tree/index-datum} returns the datum associated with the @var{index}th key and @code{wt-tree/index-pair} returns a new pair -@code{(@var{key} . @var{datum})} which is the @code{cons} of the @var{index}th -key and its datum. The average and worst-case times required by this -operation are proportional to the logarithm of the number of -associations in the tree. +@code{(@var{key} . @var{datum})} which is the @code{cons} of the +@var{index}th key and its datum. The average and worst-case times +required by this operation are proportional to the logarithm of the +number of associations in the tree. These operations signal an error if the tree is empty, if @var{index}@code{<0}, or if @var{index} is greater than or equal to the @@ -7377,9 +7214,11 @@ Indexing can be used to find the median and maximum keys in the tree as follows: @example -median: (wt-tree/index @var{wt-tree} (quotient (wt-tree/size @var{wt-tree}) 2)) +median: (wt-tree/index @var{wt-tree} + (quotient (wt-tree/size @var{wt-tree}) 2)) -maximum: (wt-tree/index @var{wt-tree} (-1+ (wt-tree/size @var{wt-tree}))) +maximum: (wt-tree/index @var{wt-tree} + (-1+ (wt-tree/size @var{wt-tree}))) @end example @end deffn @@ -7395,13 +7234,13 @@ the number of associations in the tree. @deffn {procedure+} wt-tree/min wt-tree @deffnx {procedure+} wt-tree/min-datum wt-tree @deffnx {procedure+} wt-tree/min-pair wt-tree -Returns the association of @var{wt-tree} that has the least key under the tree's ordering relation. -@code{wt-tree/min} returns the least key, -@code{wt-tree/min-datum} returns the datum associated with the -least key and @code{wt-tree/min-pair} returns a new pair -@code{(key . datum)} which is the @code{cons} of the minimum key and its datum. -The average and worst-case times required by this operation are -proportional to the logarithm of the number of associations in the tree. +Returns the association of @var{wt-tree} that has the least key under +the tree's ordering relation. @code{wt-tree/min} returns the least key, +@code{wt-tree/min-datum} returns the datum associated with the least key +and @code{wt-tree/min-pair} returns a new pair @code{(key . datum)} +which is the @code{cons} of the minimum key and its datum. The average +and worst-case times required by this operation are proportional to the +logarithm of the number of associations in the tree. These operations signal an error if the tree is empty. They could be written @@ -7553,13 +7392,13 @@ in @var{array}.@refill @end deffn @defun array-1d-ref array index -@defunx array-2d-ref array index index -@defunx array-3d-ref array index index index +@defunx array-2d-ref array index1 index2 +@defunx array-3d-ref array index1 index2 index3 @end defun @deffn Procedure array-1d-set! array new-value index -@deffnx Procedure array-2d-set! array new-value index index -@deffnx Procedure array-3d-set! array new-value index index index +@deffnx Procedure array-2d-set! array new-value index1 index2 +@deffnx Procedure array-3d-set! array new-value index1 index2 index3 @end deffn The functions are just fast versions of @code{array-ref} and @@ -7729,6 +7568,13 @@ byte-array are unspecified. @end deffn +@deffn Function bytes-length bytes + +@code{bytes-length} returns length of byte-array @var{bytes}. +@findex bytes-length + +@end deffn + @deffn Function write-byte byte @deffnx Function write-byte byte port @@ -7866,7 +7712,8 @@ A generalization of the list-based @code{comlist:reduce-init} (@xref{Lists as sequences}) to collections which will shadow the list-based version if @code{(require 'collect)} follows @ftindex collect -@code{(require 'common-list-functions)} (@xref{Common List Functions}).@refill +@code{(require 'common-list-functions)} (@xref{Common List +Functions}).@refill @ftindex common-list-functions Examples: @@ -9520,7 +9367,10 @@ The obvious string conversion routines. These are non-destructive. The destructive versions of the functions above. @end defun - +@defun string-ci->symbol str +Converts string @var{str} to a symbol having the same case as if the +symbol had been @code{read}. +@end defun @@ -9584,12 +9434,15 @@ character of the first substring of @var{string} that is equal to @deffn Procedure find-string-from-port? str in-port max-no-chars Looks for a string @var{str} within the first @var{max-no-chars} chars of the input port @var{in-port}. + @deffnx 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. + @deffnx Procedure find-string-from-port? str in-port char Searches up to the first occurrence of character @var{char} in @var{str}. + @deffnx Procedure find-string-from-port? str in-port proc Searches up to the first occurrence of the procedure @var{proc} returning non-false when called with a character (from @var{in-port}) @@ -9606,6 +9459,11 @@ sequentially, and does not perform any buffering. So open to a pipe or other communication channel. @end deffn +@defun string-subst txt old1 new1 @dots{} +Returns a copy of string @var{txt} with all occurrences of string +@var{old1} in @var{txt} replaced with @var{new1}, @var{old2} replaced +with @var{new2} @dots{}. +@end defun @node Line I/O, Multi-Processing, String Search, Procedures @subsection Line I/O @@ -9693,6 +9551,7 @@ Kills the current process and runs the next process from * Rationalize:: 'rationalize * Promises:: 'promise * Dynamic-Wind:: 'dynamic-wind +* Eval:: 'eval * Values:: 'values @end menu @@ -9913,7 +9772,7 @@ doesn't support them -@node Dynamic-Wind, Values, Promises, Standards Support +@node Dynamic-Wind, Eval, Promises, Standards Support @subsection Dynamic-Wind @code{(require 'dynamic-wind)} @@ -9943,9 +9802,99 @@ the time of the error or interrupt.@refill @end deffn +@node Eval, Values, Dynamic-Wind, Standards Support +@subsection Eval + +@code{(require 'eval)} + +@defun eval expression environment-specifier + +Evaluates @var{expression} in the specified environment and returns its +value. @var{Expression} must be a valid Scheme expression represented +as data, and @var{environment-specifier} must be a value returned by one +of the three procedures described below. Implementations may extend +@code{eval} to allow non-expression programs (definitions) as the first +argument and to allow other values as environments, with the restriction +that @code{eval} is not allowed to create new bindings in the +environments associated with @code{null-environment} or +@code{scheme-report-environment}. +@lisp +(eval '(* 7 3) (scheme-report-environment 5)) + @result{} 21 + +(let ((f (eval '(lambda (f x) (f x x)) + (null-environment)))) + (f + 10)) + @result{} 20 +@end lisp +@end defun + +@defun scheme-report-environment version +@defunx null-environment version +@defunx null-environment + +@var{Version} must be an exact non-negative integer @var{n} +corresponding to a version of one of the Revised^@var{n} Reports on +Scheme. @code{Scheme-report-environment} returns a specifier for an +environment that contains the set of bindings specified in the +corresponding report that the implementation supports. +@code{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 @var{n} of the +Revised^@var{n} Reports on Scheme must accept version @var{n}. An error +is signalled if the specified version is not available. -@node Values, , Dynamic-Wind, Standards Support +The effect of assigning (through the use of @code{eval}) a variable +bound in a @code{scheme-report-environment} (for example @code{car}) is +unspecified. Thus the environments specified by +@code{scheme-report-environment} may be immutable. + +@end defun + +@defun 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. +@end defun + +@noindent +Here are some more @code{eval} examples: + +@example +(require 'eval) +@result{} #<unspecified> +(define car 'volvo) +@result{} #<unspecified> +car +@result{} volvo +(eval 'car (interaction-environment)) +@result{} volvo +(eval 'car (scheme-report-environment 5)) +@result{} #<primitive-procedure car> +(eval '(eval 'car (interaction-environment)) + (scheme-report-environment 5)) +@result{} volvo +(eval '(eval '(set! car 'buick) (interaction-environment)) + (scheme-report-environment 5)) +@result{} #<unspecified> +car +@result{} buick +(eval 'car (scheme-report-environment 5)) +@result{} #<primitive-procedure car> +(eval '(eval 'car (interaction-environment)) + (scheme-report-environment 5)) +@result{} buick +@end example + + +@node Values, , Eval, Standards Support @subsection Values @code{(require 'values)} @@ -10116,6 +10065,7 @@ which it was called on a continuation stack. @defun continue Pops the topmost continuation off of the continuation stack and returns an unspecified value to it. + @defunx continue arg1 @dots{} Pops the topmost continuation off of the continuation stack and returns @var{arg1} @dots{} to it. @@ -10376,8 +10326,10 @@ compatability. Because of shared state they are not thread-safe. @defun tzset Returns the default time-zone. + @defunx tzset tz Sets (and returns) the default time-zone to @var{tz}. + @defunx tzset TZ-string Sets (and returns) the default time-zone to that specified by @var{TZ-string}. @@ -10436,7 +10388,7 @@ sites are: @table @asis @item SLIB-PSD is a portable debugger for Scheme (requires emacs editor). @lisp -ftp-swiss.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz +swissnet.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz @@ -10451,25 +10403,9 @@ 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 -@ifset html -<A HREF="http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html"> -@end ifset -@lisp -http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html -@end lisp -@ifset html -</A> -@end ifset +@url{http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html} @item SCHELOG is an embedding of Prolog in Scheme. -@ifset html -<A HREF="http://www.cs.rice.edu/CS/PLT/packages/schelog/"> -@end ifset -@lisp -http://www.cs.rice.edu/CS/PLT/packages/schelog/ -@end lisp -@ifset html -</A> -@end ifset +@url{http://www.cs.rice.edu/CS/PLT/packages/schelog/} @end table @@ -10536,9 +10472,10 @@ script with the name @code{slib48} which will invoke the saved image. If there is no initialization file for your Scheme implementation, you will have to create one. Your Scheme implementation must be largely -compliant with @cite{IEEE Std 1178-1990} or @cite{Revised^4 Report on -the Algorithmic Language Scheme} to support SLIB. @footnote{If you are -porting a @cite{Revised^3 Report on the Algorithmic Language Scheme} +compliant with @cite{IEEE Std 1178-1990}, @cite{Revised^4 Report on the +Algorithmic Language Scheme}, or @cite{Revised^5 Report on the +Algorithmic Language Scheme} in order to support SLIB. @footnote{If you +are porting a @cite{Revised^3 Report on the Algorithmic Language Scheme} implementation, then you will need to finish writing @file{sc4sc3.scm} and @code{load} it from your initialization file.} @@ -22,8 +22,8 @@ #t (do ((i 1 (+ i 1))) ((or (= i n) - (less? (vector-ref seq (- i 1)) - (vector-ref seq i))) + (less? (vector-ref seq i) + (vector-ref seq (- i 1)))) (= i n)) )) )) (else (let loop ((last (car seq)) (next (cdr seq))) diff --git a/strcase.scm b/strcase.scm index f223527..f2c8331 100644 --- a/strcase.scm +++ b/strcase.scm @@ -43,3 +43,8 @@ (define (string-capitalize str) (string-capitalize! (string-copy str))) + +(define string-ci->symbol + (if (equal? "a" (symbol->string 'a)) + (lambda (str) (string->symbol (string-downcase str))) + (lambda (str) (string->symbol (string-upcase str))))) diff --git a/strsrch.scm b/strsrch.scm index b25c229..68bcf0e 100644 --- a/strsrch.scm +++ b/strsrch.scm @@ -1,6 +1,6 @@ ;;; "MISCIO" Search for string from port. ; Written 1995, 1996 by Oleg Kiselyov (oleg@ponder.csci.unt.edu) -; Modified 1996, 1997 by A. Jaffer (jaffer@ai.mit.edu) +; Modified 1996, 1997, 1998 by A. Jaffer (jaffer@ai.mit.edu) ; ; This code is in the public domain. @@ -121,3 +121,23 @@ (backtrack (+ 1 i) matched-substr-len)))))))) ) (match-1st-char))) + +(define (string-subst text old new . rest) + (define sub + (lambda (text) + (set! text + (cond ((equal? "" text) text) + ((substring? old text) + => (lambda (idx) + (string-append + (substring text 0 idx) + new + (sub (substring + text (+ idx (string-length old)) + (string-length text)))))) + (else text))) + (if (null? rest) + text + (apply string-subst text rest)))) + (sub text)) + @@ -193,8 +193,7 @@ ;;; Return argument (define (identity x) x) -;;; If your implementation provides eval, SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define (slib:eval form) (eval form scheme-env)) ;;; If your implementation provides R4RS macros: diff --git a/timezone.scm b/timezone.scm index 8daa8fb..2890c39 100644 --- a/timezone.scm +++ b/timezone.scm @@ -57,6 +57,25 @@ (define tz:default #f) +;;; This definition is here so that READ-TZFILE can verify the +;;; existence of these files before loading tzfile.scm to actually +;;; read them. +(define tzfile:vicinity (make-vicinity "/usr/lib/zoneinfo/")) + +(define (read-tzfile path) + (let ((realpath + (cond ((not path) (in-vicinity tzfile:vicinity "localtime")) + ((or (char-alphabetic? (string-ref path 0)) + (char-numeric? (string-ref path 0))) + (in-vicinity tzfile:vicinity path)) + (else path)))) + (and (file-exists? realpath) + (let ((zone #f)) + (require 'tzfile) + (set! zone (tzfile:read realpath)) + (if zone (list->vector (cons 'tz:file zone)) + (slib:error 'read-tzfile realpath)))))) + ;;; Parse Posix TZ string. (define (string->transition-day-time str) @@ -125,21 +144,6 @@ (vector 'tz:rule tz tzname dtzname offset doffset start end)))) (else #f)))) -(define (read-tzfile path) - (require 'tzfile) - (let ((realpath - (cond ((not path) (in-vicinity tzfile:vicinity "localtime")) - ((or (char-alphabetic? (string-ref path 0)) - (char-numeric? (string-ref path 0))) - (in-vicinity tzfile:vicinity path)) - (else path)))) - (if (file-exists? realpath) - (let ((zone (tzfile:read realpath))) - (if zone (list->vector (cons 'tz:file zone)) - (slib:error 'read-tzfile realpath))) - (slib:error 'read-tzfile "file not found:" realpath) - ))) - (define (time-zone tz) (cond ((not tz) (read-tzfile #f)) ((vector? tz) tz) @@ -40,9 +40,9 @@ (else (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ )) (apply qpn CALL name args) - (set! debug:indent (modulo (+ 1 debug:indent) 8)) + (set! debug:indent (modulo (+ 1 debug:indent) 16)) (let ((ans (apply function args))) - (set! debug:indent (modulo (+ -1 debug:indent) 8)) + (set! debug:indent (modulo (+ -1 debug:indent) 16)) (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ )) (qpn RETN name ans) ans)))))))) @@ -96,7 +96,8 @@ (defmacro trace xs (if (null? xs) - `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) + `(begin (set! debug:indent 0) + ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) (map car *traced-procedures*)) (map car *traced-procedures*)) `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) xs)))) @@ -19,8 +19,6 @@ (require 'byte) -(define tzfile:vicinity (make-vicinity "/usr/lib/zoneinfo/")) - (define (tzfile:read-long port) (let ((hibyte (read-byte port))) (do ((idx 3 (+ -1 idx)) @@ -131,8 +131,8 @@ ; 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 + defmacro ;has Common Lisp DEFMACRO +; eval ;proposed 2-argument eval ; record ;has user defined data structures values ;proposed multiple values ; dynamic-wind ;proposed dynamic-wind @@ -168,7 +168,7 @@ (define (output-port-width . arg) 79) ;;; (CURRENT-ERROR-PORT) -(define current-error-port +(define (current-error-port) (standard-port 2)) ;;; (TMPNAM) makes a temporary file name. @@ -269,8 +269,7 @@ ;;; Return argument (define (identity x) x) -;;; If your implementation provides eval SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) ;;; If your implementation provides R4RS macros: @@ -333,7 +332,8 @@ (for-each (lambda (x) (display x port)) args)))) ;;; define an error procedure for the library -(define slib:error error) +(define (slib:error . argl) + (error argl)) ;;; define these as appropriate for your system. (define slib:tab #\Tab) @@ -1,7 +1,7 @@ ;; "wttree.scm" Weight balanced trees -*-Scheme-*- ;; Copyright (c) 1993-1994 Stephen Adams ;; -;; $Id: wttree.scm,v 1.1 1994/11/28 21:58:48 adams Exp adams $ +;; $Id: wttree.scm,v 1.2 1998/02/09 23:13:10 jaffer Exp $ ;; ;; References: ;; |